Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/misc/volume10/xlisp21/part06

Text File | 1990-02-26 | 96.0 KB | 3,873 lines

Newsgroups: comp.sources.misc
organization: Cognos Inc., Ottawa, Canada
subject: v10i093: XLisP 2.1 sources 3b (2/2) / 5
From: [e-mail] (Gary Murphy)
Sender: [e-mail] (Brandon S. Allbery - comp.sources.misc)

Posting-number: Volume 10, Issue 93
Submitted-by: [e-mail] (Gary Murphy)
Archive-name: xlisp21/part06

#!/bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #!/bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    xlfio.c
#    xlftab.c
#    xlglob.c
#    xlimage.c
#    xlinit.c
#    xlio.c
#    xlisp.c
#    xlisp.h
#    xlisp.lnk
#    xlisp.mac
# This archive created: Sun Feb 18 23:37:48 1990
# By:    Gary Murphy ()
export PATH; PATH=/bin:$PATH
echo shar: extracting "'xlfio.c'" '(9976 characters)'
if test -f 'xlfio.c'
then
    echo shar: over-writing existing file "'xlfio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlfio.c'
X/* xlfio.c - xlisp file i/o */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL k_direction,k_input,k_output;
Xextern LVAL s_stdin,s_stdout,true;
Xextern unsigned char buf[];
Xextern int xlfsize;
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* forward declarations */
XFORWARD LVAL getstroutput();
XFORWARD LVAL printit();
XFORWARD LVAL flatsize();
XFORWARD LVAL openit();
X
X/* xread - read an expression */
XLVAL xread()
X{
X    LVAL fptr,eof,rflag,val;
X
X    /* get file pointer and eof value */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    eof = (moreargs() ? xlgetarg() : NIL);
X    rflag = (moreargs() ? xlgetarg() : NIL);
X    xllastarg();
X
X    /* read an expression */
X    if (!xlread(fptr,&val,rflag != NIL))
X    val = eof;
X
X    /* return the expression */
X    return (val);
X}
X
X/* xprint - built-in function 'print' */
XLVAL xprint()
X{
X    return (printit(TRUE,TRUE));
X}
X
X/* xprin1 - built-in function 'prin1' */
XLVAL xprin1()
X{
X    return (printit(TRUE,FALSE));
X}
X
X/* xprinc - built-in function princ */
XLVAL xprinc()
X{
X    return (printit(FALSE,FALSE));
X}
X
X/* xterpri - terminate the current print line */
XLVAL xterpri()
X{
X    LVAL fptr;
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* terminate the print line and return nil */
X    xlterpri(fptr);
X    return (NIL);
X}
X
X/* printit - common print function */
XLOCAL LVAL printit(pflag,tflag)
X  int pflag,tflag;
X{
X    LVAL fptr,val;
X
X    /* get expression to print and file pointer */
X    val = xlgetarg();
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* print the value */
X    xlprint(fptr,val,pflag);
X
X    /* terminate the print line if necessary */
X    if (tflag)
X    xlterpri(fptr);
X
X    /* return the result */
X    return (val);
X}
X
X/* xflatsize - compute the size of a printed representation using prin1 */
XLVAL xflatsize()
X{
X    return (flatsize(TRUE));
X}
X
X/* xflatc - compute the size of a printed representation using princ */
XLVAL xflatc()
X{
X    return (flatsize(FALSE));
X}
X
X/* flatsize - compute the size of a printed expression */
XLOCAL LVAL flatsize(pflag)
X  int pflag;
X{
X    LVAL val;
X
X    /* get the expression */
X    val = xlgetarg();
X    xllastarg();
X
X    /* print the value to compute its size */
X    xlfsize = 0;
X    xlprint(NIL,val,pflag);
X
X    /* return the length of the expression */
X    return (cvfixnum((FIXTYPE)xlfsize));
X}
X
X/* xopen - open a file */
XLVAL xopen()
X{
X    char *name,*mode;
X    FILE *fp;
X    LVAL dir;
X
X    /* get the file name and direction */
X    name = (char *)getstring(xlgetfname());
X    if (!xlgetkeyarg(k_direction,&dir))
X    dir = k_input;
X
X    /* get the mode */
X    if (dir == k_input)
X    mode = "r";
X    else if (dir == k_output)
X    mode = "w";
X    else
X    xlerror("bad direction",dir);
X
X    /* try to open the file */
X    return ((fp = osaopen(name,mode)) ? cvfile(fp) : NIL);
X}
X
X/* xclose - close a file */
XLVAL xclose()
X{
X    LVAL fptr;
X
X    /* get file pointer */
X    fptr = xlgastream();
X    xllastarg();
X
X    /* make sure the file exists */
X    if (getfile(fptr) == NULL)
X    xlfail("file not open");
X
X    /* close the file */
X    osclose(getfile(fptr));
X    setfile(fptr,NULL);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xrdchar - read a character from a file */
XLVAL xrdchar()
X{
X    LVAL fptr;
X    int ch;
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* get character and check for eof */
X    return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
X}
X
X/* xrdbyte - read a byte from a file */
XLVAL xrdbyte()
X{
X    LVAL fptr;
X    int ch;
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* get character and check for eof */
X    return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
X}
X
X/* xpkchar - peek at a character from a file */
XLVAL xpkchar()
X{
X    LVAL flag,fptr;
X    int ch;
X
X    /* peek flag and get file pointer */
X    flag = (moreargs() ? xlgetarg() : NIL);
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* skip leading white space and get a character */
X    if (flag)
X    while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
X        xlgetc(fptr);
X    else
X    ch = xlpeek(fptr);
X
X    /* return the character */
X    return (ch == EOF ? NIL : cvchar(ch));
X}
X
X/* xwrchar - write a character to a file */
XLVAL xwrchar()
X{
X    LVAL fptr,chr;
X
X    /* get the character and file pointer */
X    chr = xlgachar();
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* put character to the file */
X    xlputc(fptr,getchcode(chr));
X
X    /* return the character */
X    return (chr);
X}
X
X/* xwrbyte - write a byte to a file */
XLVAL xwrbyte()
X{
X    LVAL fptr,chr;
X
X    /* get the byte and file pointer */
X    chr = xlgafixnum();
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* put byte to the file */
X    xlputc(fptr,(int)getfixnum(chr));
X
X    /* return the character */
X    return (chr);
X}
X
X/* xreadline - read a line from a file */
XLVAL xreadline()
X{
X    unsigned char buf[STRMAX+1],*p,*sptr;
X    LVAL fptr,str,newstr;
X    int len,blen,ch;
X
X    /* protect some pointers */
X    xlsave1(str);
X
X    /* get file pointer */
X    fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
X    xllastarg();
X
X    /* get character and check for eof */
X    len = blen = 0; p = buf;
X    while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
X
X    /* check for buffer overflow */
X    if (blen >= STRMAX) {
X         newstr = newstring(len + STRMAX + 1);
X        sptr = getstring(newstr); *sptr = '\0';
X        if (str) strcat(sptr,getstring(str));
X        *p = '\0'; strcat(sptr,buf);
X        p = buf; blen = 0;
X        len += STRMAX;
X        str = newstr;
X    }
X
X    /* store the character */
X    *p++ = ch; ++blen;
X    }
X
X    /* check for end of file */
X    if (len == 0 && p == buf && ch == EOF) {
X    xlpop();
X    return (NIL);
X    }
X
X    /* append the last substring */
X    if (str == NIL || blen) {
X    newstr = newstring(len + blen + 1);
X    sptr = getstring(newstr); *sptr = '\0';
X    if (str) strcat(sptr,getstring(str));
X    *p = '\0'; strcat(sptr,buf);
X    str = newstr;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the string */
X    return (str);
X}
X
X
X/* xmkstrinput - make a string input stream */
XLVAL xmkstrinput()
X{
X    int start,end,len,i;
X    unsigned char *str;
X    LVAL string,val;
X
X    /* protect the return value */
X    xlsave1(val);
X
X    /* get the string and length */
X    string = xlgastring();
X    str = getstring(string);
X    len = getslength(string) - 1;
X
X    /* get the starting offset */
X    if (moreargs()) {
X    val = xlgafixnum();
X    start = (int)getfixnum(val);
X    }
X    else start = 0;
X
X    /* get the ending offset */
X    if (moreargs()) {
X    val = xlgafixnum();
X    end = (int)getfixnum(val);
X    }
X    else end = len;
X    xllastarg();
X
X    /* check the bounds */
X    if (start < 0 || start > len)
X    xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
X    if (end < 0 || end > len)
X    xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
X
X    /* make the stream */
X    val = newustream();
X
X    /* copy the substring into the stream */
X    for (i = start; i < end; ++i)
X    xlputc(val,str[i]);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new stream */
X    return (val);
X}
X
X/* xmkstroutput - make a string output stream */
XLVAL xmkstroutput()
X{
X    return (newustream());
X}
X
X/* xgetstroutput - get output stream string */
XLVAL xgetstroutput()
X{
X    LVAL stream;
X    stream = xlgaustream();
X    xllastarg();
X    return (getstroutput(stream));
X}
X
X/* xgetlstoutput - get output stream list */
XLVAL xgetlstoutput()
X{
X    LVAL stream,val;
X
X    /* get the stream */
X    stream = xlgaustream();
X    xllastarg();
X
X    /* get the output character list */
X    val = gethead(stream);
X
X    /* empty the character list */
X    sethead(stream,NIL);
X    settail(stream,NIL);
X
X    /* return the list */
X    return (val);
X}
X
X/* xformat - formatted output function */
XLVAL xformat()
X{
X    LVAL fmtstring,stream,val;
X    unsigned char *fmt;
X    int ch;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fmtstring);
X    xlsave(stream);
X
X    /* get the stream and format string */
X    stream = xlgetarg();
X    if (stream == NIL)
X    val = stream = newustream();
X    else {
X    if (stream == true)
X        stream = getvalue(s_stdout);
X    else if (!streamp(stream) && !ustreamp(stream))
X        xlbadtype(stream);
X    val = NIL;
X    }
X    fmtstring = xlgastring();
X    fmt = getstring(fmtstring);
X
X    /* process the format string */
X    while (ch = *fmt++)
X    if (ch == '~') {
X        switch (*fmt++) {
X        case '\0':
X        xlerror("expecting a format directive",cvstring(fmt-1));
X        case 'a': case 'A':
X        xlprint(stream,xlgetarg(),FALSE);
X        break;
X        case 's': case 'S':
X        xlprint(stream,xlgetarg(),TRUE);
X        break;
X        case '%':
X        xlterpri(stream);
X        break;
X        case '~':
X        xlputc(stream,'~');
X        break;
X        case '\n':
X        while (*fmt && *fmt != '\n' && isspace(*fmt))
X            ++fmt;
X        break;
X        default:
X        xlerror("unknown format directive",cvstring(fmt-1));
X        }
X    }
X    else
X        xlputc(stream,ch);
X
X    /* get the output string for a stream argument of NIL */
X    if (val) val = getstroutput(val);
X    xlpopn(2);
X
X    /* return the value */
X    return (val);
X}
X
X/* getstroutput - get the output stream string (internal) */
XLOCAL LVAL getstroutput(stream)
X  LVAL stream;
X{
X    unsigned char *str;
X    LVAL next,val;
X    int len,ch;
X
X    /* compute the length of the stream */
X    for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
X    ++len;
X
X    /* create a new string */
X    val = newstring(len + 1);
X
X    /* copy the characters into the new string */
X    str = getstring(val);
X    while ((ch = xlgetc(stream)) != EOF)
X    *str++ = ch;
X    *str = '\0';
X
X    /* return the string */
X    return (val);
X}
X
SHAR_EOF
if test 9976 -ne "`wc -c 'xlfio.c'`"
then
    echo shar: error transmitting "'xlfio.c'" '(should have been 9976 characters)'
fi
echo shar: extracting "'xlftab.c'" '(16622 characters)'
if test -f 'xlftab.c'
then
    echo shar: over-writing existing file "'xlftab.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlftab.c'
X/* xlftab.c - xlisp function table */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external functions */
Xextern LVAL
X    xbisubr(),xbifsubr(),
X    rmhash(),rmquote(),rmdquote(),rmbquote(),rmcomma(),
X    clnew(),clisnew(),clanswer(),
X    obisnew(),obclass(),obshow(),
X    rmlpar(),rmrpar(),rmsemi(),
X    xeval(),xapply(),xfuncall(),xquote(),xfunction(),xbquote(),
X    xlambda(),xset(),xsetq(),xsetf(),xdefun(),xdefmacro(),
X    xgensym(),xmakesymbol(),xintern(),
X    xsymname(),xsymvalue(),xsymplist(),
X    xget(),xputprop(),xremprop(),
X    xhash(),xmkarray(),xaref(),
X    xcar(),xcdr(),
X    xcaar(),xcadr(),xcdar(),xcddr(),
X    xcaaar(),xcaadr(),xcadar(),xcaddr(),
X    xcdaar(),xcdadr(),xcddar(),xcdddr(),
X    xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(),
X    xcadaar(),xcadadr(),xcaddar(),xcadddr(),
X    xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(),
X    xcddaar(),xcddadr(),xcdddar(),xcddddr(),
X    xcons(),xlist(),xappend(),xreverse(),xlast(),xnth(),xnthcdr(),
X    xmember(),xassoc(),xsubst(),xsublis(),xlength(),xsort(),
X    xremove(),xremif(),xremifnot(),
X    xmapc(),xmapcar(),xmapl(),xmaplist(),
X    xrplca(),xrplcd(),xnconc(),
X    xdelete(),xdelif(),xdelifnot(),
X    xatom(),xsymbolp(),xnumberp(),xboundp(),xnull(),xlistp(),xendp(),xconsp(),
X    xeq(),xeql(),xequal(),
X    xcond(),xcase(),xand(),xor(),xlet(),xletstar(),xif(),
X    xprog(),xprogstar(),xprog1(),xprog2(),xprogn(),xgo(),xreturn(),
X    xcatch(),xthrow(),
X    xerror(),xcerror(),xbreak(),
X    xcleanup(),xtoplevel(),xcontinue(),xerrset(),
X    xbaktrace(),xevalhook(),
X    xdo(),xdostar(),xdolist(),xdotimes(),
X    xminusp(),xzerop(),xplusp(),xevenp(),xoddp(),
X    xfix(),xfloat(),
X    xgcd(),xadd(),xsub(),xmul(),xdiv(),xrem(),xmin(),xmax(),xabs(),
X    xadd1(),xsub1(),xlogand(),xlogior(),xlogxor(),xlognot(),
X    xsin(),xcos(),xtan(),xexpt(),xexp(),xsqrt(),xrand(),
X    xlss(),xleq(),xequ(),xneq(),xgeq(),xgtr(),
X    xstrcat(),xsubseq(),xstring(),xchar(),
X    xread(),xprint(),xprin1(),xprinc(),xterpri(),
X    xflatsize(),xflatc(),
X    xopen(),xclose(),xrdchar(),xpkchar(),xwrchar(),xreadline(),
X    xload(),xtranscript(),
X    xtype(),xexit(),xpeek(),xpoke(),xaddrs(),
X    xvector(),xblock(),xrtnfrom(),xtagbody(),
X    xpsetq(),xflet(),xlabels(),xmacrolet(),xunwindprotect(),xpp(),
X    xstrlss(),xstrleq(),xstreql(),xstrneq(),xstrgeq(),xstrgtr(),
X    xstrilss(),xstrileq(),xstrieql(),xstrineq(),xstrigeq(),xstrigtr(),
X    xupcase(),xdowncase(),xnupcase(),xndowncase(),
X    xtrim(),xlefttrim(),xrighttrim(),
X    xuppercasep(),xlowercasep(),xbothcasep(),xdigitp(),xalphanumericp(),
X    xcharcode(),xcodechar(),xchupcase(),xchdowncase(),xdigitchar(),
X    xchrlss(),xchrleq(),xchreql(),xchrneq(),xchrgeq(),xchrgtr(),
X    xchrilss(),xchrileq(),xchrieql(),xchrineq(),xchrigeq(),xchrigtr(),
X    xintegerp(),xfloatp(),xstringp(),xarrayp(),xstreamp(),xobjectp(),
X    xwhen(),xunless(),xloop(),
X    xsymfunction(),xfboundp(),xsend(),xsendsuper(),
X    xprogv(),xrdbyte(),xwrbyte(),xformat(),
X    xcharp(),xcharint(),xintchar(),
X    xmkstrinput(),xmkstroutput(),xgetstroutput(),xgetlstoutput(),
X    xgetlambda(),xmacroexpand(),x1macroexpand(),
X    xtrace(),xuntrace(),
X    xdefstruct(),xmkstruct(),xcpystruct(),xstrref(),xstrset(),xstrtypep(),
X    xasin(),xacos(),xatan();
X
X/* functions specific to xldmem.c */
XLVAL xgc(),xexpand(),xalloc(),xmem();
X#ifdef SAVERESTORE
XLVAL xsave(),xrestore();
X#endif
X
X/* include system dependant definitions */
X#include "osdefs.h"
X
X/* SUBR/FSUBR indicator */
X#define S    SUBR
X#define F    FSUBR
X
X/* forward declarations */
XLVAL xnotimp();
X
X/* the function table */
XFUNDEF funtab[] = {
X
X    /* read macro functions */
X{    NULL,                S, rmhash        }, /*   0 */
X{    NULL,                S, rmquote        }, /*   1 */
X{    NULL,                S, rmdquote        }, /*   2 */
X{    NULL,                S, rmbquote        }, /*   3 */
X{    NULL,                S, rmcomma        }, /*   4 */
X{    NULL,                S, rmlpar        }, /*   5 */
X{    NULL,                S, rmrpar        }, /*   6 */
X{    NULL,                S, rmsemi        }, /*   7 */
X{    NULL,                S, xnotimp        }, /*   8 */
X{    NULL,                S, xnotimp        }, /*   9 */
X
X    /* methods */
X{    NULL,                S, clnew        }, /*  10 */
X{    NULL,                S, clisnew        }, /*  11 */
X{    NULL,                S, clanswer        }, /*  12 */
X{    NULL,                S, obisnew        }, /*  13 */
X{    NULL,                S, obclass        }, /*  14 */
X{    NULL,                S, obshow        }, /*  15 */
X{    NULL,                S, xnotimp        }, /*  16 */
X{    NULL,                S, xnotimp        }, /*  17 */
X{    NULL,                S, xnotimp        }, /*  18 */
X{    NULL,                S, xnotimp        }, /*  19 */
X
X    /* evaluator functions */
X{    "EVAL",                S, xeval        }, /*  20 */
X{    "APPLY",            S, xapply        }, /*  21 */
X{    "FUNCALL",            S, xfuncall        }, /*  22 */
X{    "QUOTE",            F, xquote        }, /*  23 */
X{    "FUNCTION",            F, xfunction        }, /*  24 */
X{    "BACKQUOTE",            F, xbquote        }, /*  25 */
X{    "LAMBDA",            F, xlambda        }, /*  26 */
X
X    /* symbol functions */
X{    "SET",                S, xset            }, /*  27 */
X{    "SETQ",                F, xsetq        }, /*  28 */
X{    "SETF",                F, xsetf        }, /*  29 */
X{    "DEFUN",            F, xdefun        }, /*  30 */
X{    "DEFMACRO",            F, xdefmacro        }, /*  31 */
X{    "GENSYM",            S, xgensym        }, /*  32 */
X{    "MAKE-SYMBOL",            S, xmakesymbol        }, /*  33 */
X{    "INTERN",             S, xintern        }, /*  34 */
X{    "SYMBOL-NAME",            S, xsymname        }, /*  35 */
X{    "SYMBOL-VALUE",            S, xsymvalue        }, /*  36 */
X{    "SYMBOL-PLIST",            S, xsymplist        }, /*  37 */
X{    "GET",                S, xget            }, /*  38 */
X{    "PUTPROP",             S, xputprop        }, /*  39 */
X{    "REMPROP",            S, xremprop        }, /*  40 */
X{    "HASH",                S, xhash        }, /*  41 */
X
X    /* array functions */
X{    "MAKE-ARRAY",            S, xmkarray        }, /*  42 */
X{    "AREF",                S, xaref        }, /*  43 */
X
X    /* list functions */
X{    "CAR",                S, xcar            }, /*  44 */
X{    "CDR",                S, xcdr            }, /*  45 */
X
X{    "CAAR",                S, xcaar        }, /*  46 */
X{    "CADR",                S, xcadr        }, /*  47 */
X{    "CDAR",                S, xcdar        }, /*  48 */
X{    "CDDR",                S, xcddr        }, /*  49 */
X
X{    "CAAAR",            S, xcaaar        }, /*  50 */
X{    "CAADR",            S, xcaadr        }, /*  51 */
X{    "CADAR",            S, xcadar        }, /*  52 */
X{    "CADDR",            S, xcaddr        }, /*  53 */
X{    "CDAAR",            S, xcdaar        }, /*  54 */
X{    "CDADR",            S, xcdadr        }, /*  55 */
X{    "CDDAR",            S, xcddar        }, /*  56 */
X{    "CDDDR",            S, xcdddr        }, /*  57 */
X
X{    "CAAAAR",             S, xcaaaar        }, /*  58 */
X{    "CAAADR",            S, xcaaadr        }, /*  59 */
X{    "CAADAR",            S, xcaadar        }, /*  60 */
X{    "CAADDR",            S, xcaaddr        }, /*  61 */
X{    "CADAAR",             S, xcadaar        }, /*  62 */
X{    "CADADR",            S, xcadadr        }, /*  63 */
X{    "CADDAR",            S, xcaddar        }, /*  64 */
X{    "CADDDR",            S, xcadddr        }, /*  65 */
X{    "CDAAAR",            S, xcdaaar        }, /*  66 */
X{    "CDAADR",            S, xcdaadr        }, /*  67 */
X{    "CDADAR",            S, xcdadar        }, /*  68 */
X{    "CDADDR",            S, xcdaddr        }, /*  69 */
X{    "CDDAAR",            S, xcddaar        }, /*  70 */
X{    "CDDADR",            S, xcddadr        }, /*  71 */
X{    "CDDDAR",            S, xcdddar        }, /*  72 */
X{    "CDDDDR",            S, xcddddr        }, /*  73 */
X
X{    "CONS",                S, xcons        }, /*  74 */
X{    "LIST",                S, xlist        }, /*  75 */
X{    "APPEND",            S, xappend        }, /*  76 */
X{    "REVERSE",            S, xreverse        }, /*  77 */
X{    "LAST",                S, xlast        }, /*  78 */
X{    "NTH",                S, xnth            }, /*  79 */
X{    "NTHCDR",            S, xnthcdr        }, /*  80 */
X{    "MEMBER",            S, xmember        }, /*  81 */
X{    "ASSOC",            S, xassoc        }, /*  82 */
X{    "SUBST",             S, xsubst        }, /*  83 */
X{    "SUBLIS",            S, xsublis        }, /*  84 */
X{    "REMOVE",            S, xremove        }, /*  85 */
X{    "LENGTH",            S, xlength        }, /*  86 */
X{    "MAPC",                S, xmapc        }, /*  87 */
X{    "MAPCAR",            S, xmapcar        }, /*  88 */
X{    "MAPL",                S, xmapl        }, /*  89 */
X{    "MAPLIST",            S, xmaplist        }, /*  90 */
X
X    /* destructive list functions */
X{    "RPLACA",            S, xrplca        }, /*  91 */
X{    "RPLACD",            S, xrplcd        }, /*  92 */
X{    "NCONC",            S, xnconc        }, /*  93 */
X{    "DELETE",            S, xdelete        }, /*  94 */
X
X    /* predicate functions */
X{    "ATOM",                S, xatom        }, /*  95 */
X{    "SYMBOLP",            S, xsymbolp        }, /*  96 */
X{    "NUMBERP",            S, xnumberp        }, /*  97 */
X{    "BOUNDP",            S, xboundp         }, /*  98 */
X{    "NULL",                S, xnull        }, /*  99 */
X{    "LISTP",            S, xlistp        }, /* 100 */
X{    "CONSP",            S, xconsp        }, /* 101 */
X{    "MINUSP",            S, xminusp         }, /* 102 */
X{    "ZEROP",            S, xzerop        }, /* 103 */
X{    "PLUSP",            S, xplusp        }, /* 104 */
X{    "EVENP",            S, xevenp        }, /* 105 */
X{    "ODDP",                S, xoddp        }, /* 106 */
X{    "EQ",                S, xeq            }, /* 107 */
X{    "EQL",                S, xeql            }, /* 108 */
X{    "EQUAL",            S, xequal        }, /* 109 */
X
X    /* special forms */
X{    "COND",                F, xcond        }, /* 110 */
X{    "CASE",                F, xcase        }, /* 111 */
X{    "AND",                F, xand            }, /* 112 */
X{    "OR",                F, xor            }, /* 113 */
X{    "LET",                F, xlet            }, /* 114 */
X{    "LET*",                F, xletstar        }, /* 115 */
X{    "IF",                F, xif            }, /* 116 */
X{    "PROG",                F, xprog        }, /* 117 */
X{    "PROG*",            F, xprogstar        }, /* 118 */
X{    "PROG1",            F, xprog1        }, /* 119 */
X{    "PROG2",            F, xprog2        }, /* 120 */
X{    "PROGN",            F, xprogn        }, /* 121 */
X{    "GO",                F, xgo            }, /* 122 */
X{    "RETURN",            F, xreturn          }, /* 123 */
X{    "DO",                F, xdo            }, /* 124 */
X{    "DO*",                F, xdostar          }, /* 125 */
X{    "DOLIST",            F, xdolist          }, /* 126 */
X{    "DOTIMES",            F, xdotimes        }, /* 127 */
X{    "CATCH",            F, xcatch        }, /* 128 */
X{    "THROW",            F, xthrow        }, /* 129 */
X
X    /* debugging and error handling functions */
X{    "ERROR",            S, xerror        }, /* 130 */
X{    "CERROR",            S, xcerror          }, /* 131 */
X{    "BREAK",            S, xbreak        }, /* 132 */
X{    "CLEAN-UP",            S, xcleanup        }, /* 133 */
X{    "TOP-LEVEL",            S, xtoplevel        }, /* 134 */
X{    "CONTINUE",            S, xcontinue        }, /* 135 */
X{    "ERRSET",             F, xerrset          }, /* 136 */
X{    "BAKTRACE",            S, xbaktrace        }, /* 137 */
X{    "EVALHOOK",            S, xevalhook        }, /* 138 */
X
X    /* arithmetic functions */
X{    "TRUNCATE",            S, xfix            }, /* 139 */
X{    "FLOAT",            S, xfloat        }, /* 140 */
X{    "+",                S, xadd            }, /* 141 */
X{    "-",                S, xsub            }, /* 142 */
X{    "*",                S, xmul            }, /* 143 */
X{    "/",                S, xdiv            }, /* 144 */
X{    "1+",                S, xadd1        }, /* 145 */
X{    "1-",                S, xsub1        }, /* 146 */
X{    "REM",                S, xrem            }, /* 147 */
X{    "MIN",                S, xmin            }, /* 148 */
X{    "MAX",                S, xmax            }, /* 149 */
X{    "ABS",                S, xabs            }, /* 150 */
X{    "SIN",                S, xsin            }, /* 151 */
X{    "COS",                S, xcos            }, /* 152 */
X{    "TAN",                S, xtan            }, /* 153 */
X{    "EXPT",                S, xexpt        }, /* 154 */
X{    "EXP",                S, xexp            }, /* 155 */
X{    "SQRT",                  S, xsqrt        }, /* 156 */
X{    "RANDOM",            S, xrand        }, /* 157 */
X
X    /* bitwise logical functions */
X{    "LOGAND",            S, xlogand          }, /* 158 */
X{    "LOGIOR",            S, xlogior          }, /* 159 */
X{    "LOGXOR",            S, xlogxor          }, /* 160 */
X{    "LOGNOT",            S, xlognot          }, /* 161 */
X
X    /* numeric comparison functions */
X{    "<",                S, xlss            }, /* 162 */
X{    "<=",                S, xleq            }, /* 163 */
X{    "=",                S, xequ            }, /* 164 */
X{    "/=",                S, xneq            }, /* 165 */
X{    ">=",                S, xgeq            }, /* 166 */
X{    ">",                S, xgtr            }, /* 167 */
X
X    /* string functions */
X{    "STRCAT",            S, xstrcat          }, /* 168 */
X{    "SUBSEQ",            S, xsubseq          }, /* 169 */
X{    "STRING",            S, xstring          }, /* 170 */
X{    "CHAR",                S, xchar        }, /* 171 */
X
X    /* I/O functions */
X{    "READ",                S, xread        }, /* 172 */
X{    "PRINT",            S, xprint        }, /* 173 */
X{    "PRIN1",            S, xprin1        }, /* 174 */
X{    "PRINC",            S, xprinc        }, /* 175 */
X{    "TERPRI",            S, xterpri          }, /* 176 */
X{    "FLATSIZE",            S, xflatsize        }, /* 177 */
X{    "FLATC",            S, xflatc        }, /* 178 */
X
X    /* file I/O functions */
X{    "OPEN",                S, xopen        }, /* 179 */
X{    "FORMAT",            S, xformat          }, /* 180 */
X{    "CLOSE",            S, xclose        }, /* 181 */
X{    "READ-CHAR",            S, xrdchar          }, /* 182 */
X{    "PEEK-CHAR",            S, xpkchar          }, /* 183 */
X{    "WRITE-CHAR",            S, xwrchar          }, /* 184 */
X{    "READ-LINE",            S, xreadline        }, /* 185 */
X
X    /* system functions */
X{    "LOAD",                S, xload        }, /* 186 */
X{    "DRIBBLE",            S, xtranscript        }, /* 187 */
X
X/* functions specific to xldmem.c */
X{    "GC",                S, xgc            }, /* 188 */
X{    "EXPAND",            S, xexpand          }, /* 189 */
X{    "ALLOC",            S, xalloc        }, /* 190 */
X{    "ROOM",                S, xmem            }, /* 191 */
X#ifdef SAVERESTORE
X{    "SAVE",                S, xsave        }, /* 192 */
X{    "RESTORE",            S, xrestore        }, /* 193 */
X#else
X{    NULL,                S, xnotimp        }, /* 192 */
X{    NULL,                S, xnotimp        }, /* 193 */
X#endif
X/* end of functions specific to xldmem.c */
X
X{    "TYPE-OF",            S, xtype        }, /* 194 */
X{    "EXIT",                S, xexit        }, /* 195 */
X{    "PEEK",                S, xpeek        }, /* 196 */
X{    "POKE",                S, xpoke        }, /* 197 */
X{    "ADDRESS-OF",            S, xaddrs        }, /* 198 */
X
X    /* new functions and special forms */
X{    "VECTOR",            S, xvector          }, /* 199 */
X{    "BLOCK",            F, xblock        }, /* 200 */
X{    "RETURN-FROM",            F, xrtnfrom        }, /* 201 */
X{    "TAGBODY",            F, xtagbody        }, /* 202 */
X{    "PSETQ",            F, xpsetq        }, /* 203 */
X{    "FLET",                F, xflet        }, /* 204 */
X{    "LABELS",            F, xlabels          }, /* 205 */
X{    "MACROLET",            F, xmacrolet        }, /* 206 */
X{    "UNWIND-PROTECT",        F, xunwindprotect    }, /* 207 */
X{    "PPRINT",            S, xpp            }, /* 208 */
X{    "STRING<",            S, xstrlss          }, /* 209 */
X{    "STRING<=",            S, xstrleq          }, /* 210 */
X{    "STRING=",            S, xstreql          }, /* 211 */
X{    "STRING/=",            S, xstrneq          }, /* 212 */
X{    "STRING>=",            S, xstrgeq          }, /* 213 */
X{    "STRING>",            S, xstrgtr          }, /* 214 */
X{    "STRING-LESSP",            S, xstrilss        }, /* 215 */
X{    "STRING-NOT-GREATERP",        S, xstrileq        }, /* 216 */
X{    "STRING-EQUAL",            S, xstrieql        }, /* 217 */
X{    "STRING-NOT-EQUAL",        S, xstrineq        }, /* 218 */
X{    "STRING-NOT-LESSP",        S, xstrigeq        }, /* 219 */
X{    "STRING-GREATERP",        S, xstrigtr        }, /* 220 */
X{    "INTEGERP",            S, xintegerp        }, /* 221 */
X{    "FLOATP",            S, xfloatp          }, /* 222 */
X{    "STRINGP",            S, xstringp        }, /* 223 */
X{    "ARRAYP",            S, xarrayp          }, /* 224 */
X{    "STREAMP",            S, xstreamp        }, /* 225 */
X{    "OBJECTP",            S, xobjectp        }, /* 226 */
X{    "STRING-UPCASE",        S, xupcase          }, /* 227 */
X{    "STRING-DOWNCASE",        S, xdowncase        }, /* 228 */
X{    "NSTRING-UPCASE",        S, xnupcase        }, /* 229 */
X{    "NSTRING-DOWNCASE",        S, xndowncase        }, /* 230 */
X{    "STRING-TRIM",            S, xtrim        }, /* 231 */
X{    "STRING-LEFT-TRIM",        S, xlefttrim        }, /* 232 */
X{    "STRING-RIGHT-TRIM",        S, xrighttrim        }, /* 233 */
X{    "WHEN",                F, xwhen        }, /* 234 */
X{    "UNLESS",            F, xunless          }, /* 235 */
X{    "LOOP",                F, xloop        }, /* 236 */
X{    "SYMBOL-FUNCTION",        S, xsymfunction        }, /* 237 */
X{    "FBOUNDP",            S, xfboundp        }, /* 238 */
X{    "SEND",                S, xsend        }, /* 239 */
X{    "SEND-SUPER",            S, xsendsuper        }, /* 240 */
X{    "PROGV",            F, xprogv        }, /* 241 */
X{    "CHARACTERP",            S, xcharp        }, /* 242 */
X{    "CHAR-INT",            S, xcharint        }, /* 243 */
X{    "INT-CHAR",            S, xintchar        }, /* 244 */
X{    "READ-BYTE",            S, xrdbyte          }, /* 245 */
X{    "WRITE-BYTE",            S, xwrbyte          }, /* 246 */
X{    "MAKE-STRING-INPUT-STREAM",     S, xmkstrinput        }, /* 247 */
X{    "MAKE-STRING-OUTPUT-STREAM",    S, xmkstroutput        }, /* 248 */
X{    "GET-OUTPUT-STREAM-STRING",    S, xgetstroutput    }, /* 249 */
X{    "GET-OUTPUT-STREAM-LIST",    S, xgetlstoutput    }, /* 250 */
X{    "GCD",                S, xgcd            }, /* 251 */
X{    "GET-LAMBDA-EXPRESSION",     S, xgetlambda        }, /* 252 */
X{    "MACROEXPAND",            S, xmacroexpand        }, /* 253 */
X{    "MACROEXPAND-1",        S, x1macroexpand    }, /* 254 */
X{    "CHAR<",            S, xchrlss          }, /* 255 */
X{    "CHAR<=",            S, xchrleq          }, /* 256 */
X{    "CHAR=",            S, xchreql          }, /* 257 */
X{    "CHAR/=",            S, xchrneq          }, /* 258 */
X{    "CHAR>=",            S, xchrgeq          }, /* 259 */
X{    "CHAR>",            S, xchrgtr          }, /* 260 */
X{    "CHAR-LESSP",            S, xchrilss        }, /* 261 */
X{    "CHAR-NOT-GREATERP",        S, xchrileq        }, /* 262 */
X{    "CHAR-EQUAL",            S, xchrieql        }, /* 263 */
X{    "CHAR-NOT-EQUAL",        S, xchrineq        }, /* 264 */
X{    "CHAR-NOT-LESSP",        S, xchrigeq        }, /* 265 */
X{    "CHAR-GREATERP",        S, xchrigtr        }, /* 266 */
X{    "UPPER-CASE-P",            S, xuppercasep        }, /* 267 */
X{    "LOWER-CASE-P",            S, xlowercasep        }, /* 268 */
X{    "BOTH-CASE-P",            S, xbothcasep        }, /* 269 */
X{    "DIGIT-CHAR-P",            S, xdigitp        }, /* 270 */
X{    "ALPHANUMERICP",        S, xalphanumericp    }, /* 271 */
X{    "CHAR-UPCASE",            S, xchupcase        }, /* 272 */
X{    "CHAR-DOWNCASE",        S, xchdowncase        }, /* 273 */
X{    "DIGIT-CHAR",            S, xdigitchar        }, /* 274 */
X{    "CHAR-CODE",            S, xcharcode        }, /* 275 */
X{    "CODE-CHAR",            S, xcodechar        }, /* 276 */
X{    "ENDP",                S, xendp        }, /* 277 */
X{    "REMOVE-IF",            S, xremif        }, /* 278 */
X{    "REMOVE-IF-NOT",        S, xremifnot        }, /* 279 */
X{    "DELETE-IF",            S, xdelif        }, /* 280 */
X{    "DELETE-IF-NOT",        S, xdelifnot        }, /* 281 */
X{    "TRACE",            F, xtrace        }, /* 282 */
X{    "UNTRACE",            F, xuntrace        }, /* 283 */
X{    "SORT",                S, xsort        }, /* 284 */
X{    "DEFSTRUCT",            F, xdefstruct        }, /* 285 */
X{    "%STRUCT-TYPE-P",        S, xstrtypep        }, /* 286 */
X{    "%MAKE-STRUCT",            S, xmkstruct        }, /* 287 */
X{    "%COPY-STRUCT",            S, xcpystruct        }, /* 288 */
X{    "%STRUCT-REF",            S, xstrref        }, /* 289 */
X{    "%STRUCT-SET",            S, xstrset        }, /* 290 */
X{    "ASIN",                S, xasin        }, /* 291 */
X{    "ACOS",                S, xacos        }, /* 292 */
X{    "ATAN",                S, xatan        }, /* 293 */
X
X    /* extra table entries */
X{    NULL,                S, xnotimp        }, /* 294 */
X{    NULL,                S, xnotimp        }, /* 295 */
X{    NULL,                S, xnotimp        }, /* 296 */
X{    NULL,                S, xnotimp        }, /* 297 */
X{    NULL,                S, xnotimp        }, /* 298 */
X{    NULL,                S, xnotimp        }, /* 299 */
X
X    /* include system dependant function pointers */
X#include "osptrs.h"
X
X{0,0,0} /* end of table marker */
X
X};
X
X/* xnotimp - function table entries that are currently not implemented */
XLOCAL LVAL xnotimp()
X{
X    xlfail("function not implemented");
X}
X
SHAR_EOF
if test 16622 -ne "`wc -c 'xlftab.c'`"
then
    echo shar: error transmitting "'xlftab.c'" '(should have been 16622 characters)'
fi
echo shar: extracting "'xlglob.c'" '(2731 characters)'
if test -f 'xlglob.c'
then
    echo shar: over-writing existing file "'xlglob.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlglob.c'
X/* xlglobals - xlisp global variables */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* symbols */
XLVAL true=NIL,obarray=NIL;
XLVAL s_unbound=NIL,s_dot=NIL;
XLVAL s_quote=NIL,s_function=NIL;
XLVAL s_bquote=NIL,s_comma=NIL,s_comat=NIL;
XLVAL s_evalhook=NIL,s_applyhook=NIL,s_tracelist;
XLVAL s_lambda=NIL,s_macro=NIL;
XLVAL s_stdin=NIL,s_stdout=NIL,s_stderr=NIL,s_debugio=NIL,s_traceout=NIL;
XLVAL s_rtable=NIL;
XLVAL s_tracenable=NIL,s_tlimit=NIL,s_breakenable=NIL;
XLVAL s_setf=NIL,s_car=NIL,s_cdr=NIL,s_nth=NIL,s_aref=NIL,s_get=NIL;
XLVAL s_svalue=NIL,s_sfunction=NIL,s_splist=NIL;
XLVAL s_eql=NIL,s_gcflag=NIL,s_gchook=NIL;
XLVAL s_ifmt=NIL,s_ffmt=NIL;
XLVAL s_1plus=NIL,s_2plus=NIL,s_3plus=NIL;
XLVAL s_1star=NIL,s_2star=NIL,s_3star=NIL;
XLVAL s_minus=NIL,s_printcase=NIL;
X
X/* keywords */
XLVAL k_test=NIL,k_tnot=NIL;
XLVAL k_wspace=NIL,k_const=NIL,k_nmacro=NIL,k_tmacro=NIL;
XLVAL k_sescape=NIL,k_mescape=NIL;
XLVAL k_direction=NIL,k_input=NIL,k_output=NIL;
XLVAL k_start=NIL,k_end=NIL,k_1start=NIL,k_1end=NIL;
XLVAL k_2start=NIL,k_2end=NIL,k_count=NIL,k_key=NIL;
XLVAL k_verbose=NIL,k_print=NIL;
XLVAL k_upcase=NIL,k_downcase=NIL;
X
X/* lambda list keywords */
XLVAL lk_optional=NIL,lk_rest=NIL,lk_key=NIL,lk_aux=NIL;
XLVAL lk_allow_other_keys=NIL;
X
X/* type names */
XLVAL a_subr=NIL,a_fsubr=NIL;
XLVAL a_cons=NIL,a_symbol=NIL,a_fixnum=NIL,a_flonum=NIL;
XLVAL a_string=NIL,a_object=NIL,a_stream=NIL,a_vector=NIL;
XLVAL a_closure=NIL,a_char=NIL,a_ustream=NIL;
X
X/* evaluation variables */
XLVAL **xlstack = NULL,**xlstkbase = NULL,**xlstktop = NULL;
XLVAL xlenv=NIL,xlfenv=NIL,xldenv=NIL;
X
X/* argument stack */
XLVAL *xlargstkbase = NULL;    /* argument stack base */
XLVAL *xlargstktop = NULL;    /* argument stack top */
XLVAL *xlfp = NULL;        /* argument frame pointer */
XLVAL *xlsp = NULL;        /* argument stack pointer */
XLVAL *xlargv = NULL;        /* current argument vector */
Xint xlargc = 0;            /* current argument count */
X
X/* exception handling variables */
XCONTEXT *xlcontext = NULL;    /* current exception handler */
XCONTEXT *xltarget = NULL;    /* target context (for xljump) */
XLVAL xlvalue=NIL;        /* exception value (for xljump) */
Xint xlmask=0;            /* exception type (for xljump) */
X
X/* debugging variables */
Xint xldebug = 0;        /* debug level */
Xint xlsample = 0;        /* control character sample rate */
Xint xltrcindent = 0;        /* trace indent level */
X
X/* gensym variables */
Xchar gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
Xint gsnumber = 1;        /* gensym number */
X
X/* i/o variables */
Xint xlfsize = 0;        /* flat size of current print call */
XFILE *tfp = NULL;        /* transcript file pointer */
X
X/* general purpose string buffer */
Xchar buf[STRMAX+1] = { 0 };
X
SHAR_EOF
if test 2731 -ne "`wc -c 'xlglob.c'`"
then
    echo shar: error transmitting "'xlglob.c'" '(should have been 2731 characters)'
fi
echo shar: extracting "'xlimage.c'" '(8425 characters)'
if test -f 'xlimage.c'
then
    echo shar: over-writing existing file "'xlimage.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlimage.c'
X/* xlimage - xlisp memory image save/restore functions */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X#ifdef SAVERESTORE
X
X/* external variables */
Xextern LVAL obarray,xlenv,xlfenv,xldenv,s_gchook,s_gcflag;
Xextern long nnodes,nfree,total;
Xextern int anodes,nsegs,gccalls;
Xextern struct segment *segs,*lastseg,*fixseg,*charseg;
Xextern CONTEXT *xlcontext;
Xextern LVAL fnodes;
X
X/* local variables */
Xstatic OFFTYPE off,foff,doff;
Xstatic FILE *fp;
X
X/* external procedures */
Xextern SEGMENT *newsegment();
Xextern FILE *osbopen();
Xextern char *malloc();
X
X/* forward declarations */
XOFFTYPE readptr();
XOFFTYPE cvoptr();
XLVAL cviptr();
X
X/* xlisave - save the memory image */
Xint xlisave(fname)
X  char *fname;
X{
X    char fullname[STRMAX+1];
X    unsigned char *cp;
X    SEGMENT *seg;
X    int n,i,max;
X    LVAL p;
X
X    /* default the extension */
X    if (needsextension(fname)) {
X    strcpy(fullname,fname);
X    strcat(fullname,".wks");
X    fname = fullname;
X    }
X
X    /* open the output file */
X    if ((fp = osbopen(fname,"w")) == NULL)
X    return (FALSE);
X
X    /* first call the garbage collector to clean up memory */
X    gc();
X
X    /* write out the pointer to the *obarray* symbol */
X    writeptr(cvoptr(obarray));
X
X    /* setup the initial file offsets */
X    off = foff = (OFFTYPE)2;
X
X    /* write out all nodes that are still in use */
X    for (seg = segs; seg != NULL; seg = seg->sg_next) {
X    p = &seg->sg_nodes[0];
X    for (n = seg->sg_size; --n >= 0; ++p, off += 2)
X        switch (ntype(p)) {
X        case FREE:
X        break;
X        case CONS:
X        case USTREAM:
X        setoffset();
X        osbputc(p->n_type,fp);
X        writeptr(cvoptr(car(p)));
X        writeptr(cvoptr(cdr(p)));
X        foff += 2;
X        break;
X        default:
X        setoffset();
X        writenode(p);
X        break;
X        }
X    }
X
X    /* write the terminator */
X    osbputc(FREE,fp);
X    writeptr((OFFTYPE)0);
X
X    /* write out data portion of vector-like nodes */
X    for (seg = segs; seg != NULL; seg = seg->sg_next) {
X    p = &seg->sg_nodes[0];
X    for (n = seg->sg_size; --n >= 0; ++p)
X        switch (ntype(p)) {
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CLOSURE:
X        case STRUCT:
X        max = getsize(p);
X        for (i = 0; i < max; ++i)
X            writeptr(cvoptr(getelement(p,i)));
X        break;
X        case STRING:
X        max = getslength(p);
X        for (cp = getstring(p); --max >= 0; )
X            osbputc(*cp++,fp);
X        break;
X        }
X    }
X
X    /* close the output file */
X    osclose(fp);
X
X    /* return successfully */
X    return (TRUE);
X}
X
X/* xlirestore - restore a saved memory image */
Xint xlirestore(fname)
X  char *fname;
X{
X    extern FUNDEF funtab[];
X    char fullname[STRMAX+1];
X    unsigned char *cp;
X    int n,i,max,type;
X    SEGMENT *seg;
X    LVAL p;
X
X    /* default the extension */
X    if (needsextension(fname)) {
X    strcpy(fullname,fname);
X    strcat(fullname,".wks");
X    fname = fullname;
X    }
X
X    /* open the file */
X    if ((fp = osbopen(fname,"r")) == NULL)
X    return (FALSE);
X
X    /* free the old memory image */
X    freeimage();
X
X    /* initialize */
X    off = (OFFTYPE)2;
X    total = nnodes = nfree = 0L;
X    fnodes = NIL;
X    segs = lastseg = NULL;
X    nsegs = gccalls = 0;
X    xlenv = xlfenv = xldenv = s_gchook = s_gcflag = NIL;
X    xlstack = xlstkbase + EDEPTH;
X    xlcontext = NULL;
X
X    /* create the fixnum segment */
X    if ((fixseg = newsegment(SFIXSIZE)) == NULL)
X    xlfatal("insufficient memory - fixnum segment");
X
X    /* create the character segment */
X    if ((charseg = newsegment(CHARSIZE)) == NULL)
X    xlfatal("insufficient memory - character segment");
X
X    /* read the pointer to the *obarray* symbol */
X    obarray = cviptr(readptr());
X
X    /* read each node */
X    while ((type = osbgetc(fp)) >= 0)
X    switch (type) {
X    case FREE:
X        if ((off = readptr()) == (OFFTYPE)0)
X        goto done;
X        break;
X    case CONS:
X    case USTREAM:
X        p = cviptr(off);
X        p->n_type = type;
X        p->n_flags = 0;
X        rplaca(p,cviptr(readptr()));
X        rplacd(p,cviptr(readptr()));
X        off += 2;
X        break;
X    default:
X        readnode(type,cviptr(off));
X        off += 2;
X        break;
X    }
Xdone:
X
X    /* read the data portion of vector-like nodes */
X    for (seg = segs; seg != NULL; seg = seg->sg_next) {
X    p = &seg->sg_nodes[0];
X    for (n = seg->sg_size; --n >= 0; ++p)
X        switch (ntype(p)) {
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CLOSURE:
X        case STRUCT:
X        max = getsize(p);
X        if ((p->n_vdata = (LVAL *)malloc(max * sizeof(LVAL))) == NULL)
X            xlfatal("insufficient memory - vector");
X        total += (long)(max * sizeof(LVAL));
X        for (i = 0; i < max; ++i)
X            setelement(p,i,cviptr(readptr()));
X        break;
X        case STRING:
X        max = getslength(p);
X        if ((p->n_string = (unsigned char *)malloc(max)) == NULL)
X            xlfatal("insufficient memory - string");
X        total += (long)max;
X        for (cp = getstring(p); --max >= 0; )
X            *cp++ = osbgetc(fp);
X        break;
X        case STREAM:
X        setfile(p,NULL);
X        break;
X        case SUBR:
X        case FSUBR:
X        p->n_subr = funtab[getoffset(p)].fd_subr;
X        break;
X        }
X    }
X
X    /* close the input file */
X    osclose(fp);
X
X    /* collect to initialize the free space */
X    gc();
X
X    /* lookup all of the symbols the interpreter uses */
X    xlsymbols();
X
X    /* return successfully */
X    return (TRUE);
X}
X
X/* freeimage - free the current memory image */
XLOCAL freeimage()
X{
X    SEGMENT *seg,*next;
X    FILE *fp;
X    LVAL p;
X    int n;
X
X    /* free the data portion of vector-like nodes */
X    for (seg = segs; seg != NULL; seg = next) {
X    p = &seg->sg_nodes[0];
X    for (n = seg->sg_size; --n >= 0; ++p)
X        switch (ntype(p)) {
X        case SYMBOL:
X        case OBJECT:
X        case VECTOR:
X        case CLOSURE:
X        case STRUCT:
X        if (p->n_vsize)
X            free(p->n_vdata);
X        break;
X        case STRING:
X        if (getslength(p))
X            free(getstring(p));
X        break;
X        case STREAM:
X        if ((fp = getfile(p)) && (fp != stdin && fp != stdout))
X            osclose(getfile(p));
X        break;
X        }
X    next = seg->sg_next;
X    free(seg);
X    }
X}
X
X/* setoffset - output a positioning command if nodes have been skipped */
XLOCAL setoffset()
X{
X    if (off != foff) {
X    osbputc(FREE,fp);
X    writeptr(off);
X    foff = off;
X    }
X}
X
X/* writenode - write a node to a file */
XLOCAL writenode(node)
X  LVAL node;
X{
X    char *p = (char *)&node->n_info;
X    int n = sizeof(union ninfo);
X    osbputc(node->n_type,fp);
X    while (--n >= 0)
X    osbputc(*p++,fp);
X    foff += 2;
X}
X
X/* writeptr - write a pointer to a file */
XLOCAL writeptr(off)
X  OFFTYPE off;
X{
X    char *p = (char *)&off;
X    int n = sizeof(OFFTYPE);
X    while (--n >= 0)
X    osbputc(*p++,fp);
X}
X
X/* readnode - read a node */
XLOCAL readnode(type,node)
X  int type; LVAL node;
X{
X    char *p = (char *)&node->n_info;
X    int n = sizeof(union ninfo);
X    node->n_type = type;
X    node->n_flags = 0;
X    while (--n >= 0)
X    *p++ = osbgetc(fp);
X}
X
X/* readptr - read a pointer */
XLOCAL OFFTYPE readptr()
X{
X    OFFTYPE off;
X    char *p = (char *)&off;
X    int n = sizeof(OFFTYPE);
X    while (--n >= 0)
X    *p++ = osbgetc(fp);
X    return (off);
X}
X
X/* cviptr - convert a pointer on input */
XLOCAL LVAL cviptr(o)
X  OFFTYPE o;
X{
X    OFFTYPE off = (OFFTYPE)2;
X    SEGMENT *seg;
X
X    /* check for nil */
X    if (o == (OFFTYPE)0)
X    return ((LVAL)o);
X
X    /* compute a pointer for this offset */
X    for (seg = segs; seg != NULL; seg = seg->sg_next) {
X    if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1))
X        return (seg->sg_nodes + ((int)(o - off) >> 1));
X    off += (OFFTYPE)(seg->sg_size << 1);
X    }
X
X    /* create new segments if necessary */
X    for (;;) {
X
X    /* create the next segment */
X    if ((seg = newsegment(anodes)) == NULL)
X        xlfatal("insufficient memory - segment");
X
X    /* check to see if the offset is in this segment */
X    if (o >= off && o < off + (OFFTYPE)(seg->sg_size << 1))
X        return (seg->sg_nodes + ((int)(o - off) >> 1));
X    off += (OFFTYPE)(seg->sg_size << 1);
X    }
X}
X
X/* cvoptr - convert a pointer on output */
XLOCAL OFFTYPE cvoptr(p)
X  LVAL p;
X{
X    OFFTYPE off = (OFFTYPE)2;
X    SEGMENT *seg;
X
X    /* check for nil and small fixnums */
X    if (p == NIL)
X    return ((OFFTYPE)p);
X
X    /* compute an offset for this pointer */
X    for (seg = segs; seg != NULL; seg = seg->sg_next) {
X    if (CVPTR(p) >= CVPTR(&seg->sg_nodes[0]) &&
X        CVPTR(p) <  CVPTR(&seg->sg_nodes[0] + seg->sg_size))
X        return (off + (OFFTYPE)((p - seg->sg_nodes) << 1));
X    off += (OFFTYPE)(seg->sg_size << 1);
X    }
X
X    /* pointer not within any segment */
X    xlerror("bad pointer found during image save",p);
X}
X
X#endif
X
SHAR_EOF
if test 8425 -ne "`wc -c 'xlimage.c'`"
then
    echo shar: error transmitting "'xlimage.c'" '(should have been 8425 characters)'
fi
echo shar: extracting "'xlinit.c'" '(7703 characters)'
if test -f 'xlinit.c'
then
    echo shar: over-writing existing file "'xlinit.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlinit.c'
X/* xlinit.c - xlisp initialization module */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL true,s_dot,s_unbound;
Xextern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_stdin,s_stdout,s_stderr,s_debugio,s_traceout;
Xextern LVAL s_evalhook,s_applyhook,s_tracelist;
Xextern LVAL s_tracenable,s_tlimit,s_breakenable;
Xextern LVAL s_setf,s_car,s_cdr,s_nth,s_aref,s_get,s_eql;
Xextern LVAL s_svalue,s_sfunction,s_splist;
Xextern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
Xextern LVAL k_sescape,k_mescape;
Xextern LVAL s_ifmt,s_ffmt,s_printcase;
Xextern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
Xextern LVAL k_test,k_tnot;
Xextern LVAL k_direction,k_input,k_output;
Xextern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end;
Xextern LVAL k_verbose,k_print,k_count,k_key,k_upcase,k_downcase;
Xextern LVAL lk_optional,lk_rest,lk_key,lk_aux,lk_allow_other_keys;
Xextern LVAL a_subr,a_fsubr,a_cons,a_symbol;
Xextern LVAL a_fixnum,a_flonum,a_string,a_stream,a_object;
Xextern LVAL a_vector,a_closure,a_char,a_ustream;
Xextern LVAL s_gcflag,s_gchook;
Xextern FUNDEF funtab[];
X
X/* xlinit - xlisp initialization routine */
Xxlinit()
X{
X    /* initialize xlisp (must be in this order) */
X    xlminit();    /* initialize xldmem.c */
X    xldinit();    /* initialize xldbug.c */
X
X    /* finish initializing */
X#ifdef SAVERESTORE
X    if (!xlirestore("xlisp.wks"))
X#endif
X    initwks();
X}
X
X/* initwks - build an initial workspace */
XLOCAL initwks()
X{
X    FUNDEF *p;
X    int i;
X
X    xlsinit();    /* initialize xlsym.c */
X    xlsymbols();/* enter all symbols used by the interpreter */
X    xlrinit();    /* initialize xlread.c */
X    xloinit();    /* initialize xlobj.c */
X
X    /* setup defaults */
X    setvalue(s_evalhook,NIL);        /* no evalhook function */
X    setvalue(s_applyhook,NIL);        /* no applyhook function */
X    setvalue(s_tracelist,NIL);        /* no functions being traced */
X    setvalue(s_tracenable,NIL);        /* traceback disabled */
X    setvalue(s_tlimit,NIL);         /* trace limit infinite */
X    setvalue(s_breakenable,NIL);    /* don't enter break loop on errors */
X    setvalue(s_gcflag,NIL);        /* don't show gc information */
X    setvalue(s_gchook,NIL);        /* no gc hook active */
X    setvalue(s_ifmt,cvstring(IFMT));    /* integer print format */
X    setvalue(s_ffmt,cvstring("%g"));    /* float print format */
X    setvalue(s_printcase,k_upcase);    /* upper case output of symbols */
X
X    /* install the built-in functions and special forms */
X    for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p)
X    if (p->fd_name)
X        xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
X
X    /* add some synonyms */
X    setfunction(xlenter("NOT"),getfunction(xlenter("NULL")));
X    setfunction(xlenter("FIRST"),getfunction(xlenter("CAR")));
X    setfunction(xlenter("SECOND"),getfunction(xlenter("CADR")));
X    setfunction(xlenter("THIRD"),getfunction(xlenter("CADDR")));
X    setfunction(xlenter("FOURTH"),getfunction(xlenter("CADDDR")));
X    setfunction(xlenter("REST"),getfunction(xlenter("CDR")));
X}
X
X/* xlsymbols - enter all of the symbols used by the interpreter */
Xxlsymbols()
X{
X    LVAL sym;
X
X    /* enter the unbound variable indicator (must be first) */
X    s_unbound = xlenter("*UNBOUND*");
X    setvalue(s_unbound,s_unbound);
X
X    /* enter the 't' symbol */
X    true = xlenter("T");
X    setvalue(true,true);
X
X    /* enter some important symbols */
X    s_dot    = xlenter(".");
X    s_quote    = xlenter("QUOTE");
X    s_function    = xlenter("FUNCTION");
X    s_bquote    = xlenter("BACKQUOTE");
X    s_comma    = xlenter("COMMA");
X    s_comat    = xlenter("COMMA-AT");
X    s_lambda    = xlenter("LAMBDA");
X    s_macro    = xlenter("MACRO");
X    s_eql    = xlenter("EQL");
X    s_ifmt    = xlenter("*INTEGER-FORMAT*");
X    s_ffmt    = xlenter("*FLOAT-FORMAT*");
X
X    /* symbols set by the read-eval-print loop */
X    s_1plus    = xlenter("+");
X    s_2plus    = xlenter("++");
X    s_3plus    = xlenter("+++");
X    s_1star    = xlenter("*");
X    s_2star    = xlenter("**");
X    s_3star    = xlenter("***");
X    s_minus    = xlenter("-");
X
X    /* enter setf place specifiers */
X    s_setf    = xlenter("*SETF*");
X    s_car    = xlenter("CAR");
X    s_cdr    = xlenter("CDR");
X    s_nth    = xlenter("NTH");
X    s_aref    = xlenter("AREF");
X    s_get    = xlenter("GET");
X    s_svalue    = xlenter("SYMBOL-VALUE");
X    s_sfunction    = xlenter("SYMBOL-FUNCTION");
X    s_splist    = xlenter("SYMBOL-PLIST");
X
X    /* enter the readtable variable and keywords */
X    s_rtable    = xlenter("*READTABLE*");
X    k_wspace    = xlenter(":WHITE-SPACE");
X    k_const    = xlenter(":CONSTITUENT");
X    k_nmacro    = xlenter(":NMACRO");
X    k_tmacro    = xlenter(":TMACRO");
X    k_sescape    = xlenter(":SESCAPE");
X    k_mescape    = xlenter(":MESCAPE");
X
X    /* enter parameter list keywords */
X    k_test    = xlenter(":TEST");
X    k_tnot    = xlenter(":TEST-NOT");
X
X    /* "open" keywords */
X    k_direction = xlenter(":DIRECTION");
X    k_input     = xlenter(":INPUT");
X    k_output    = xlenter(":OUTPUT");
X
X    /* enter *print-case* symbol and keywords */
X    s_printcase = xlenter("*PRINT-CASE*");
X    k_upcase    = xlenter(":UPCASE");
X    k_downcase  = xlenter(":DOWNCASE");
X
X    /* other keywords */
X    k_start    = xlenter(":START");
X    k_end    = xlenter(":END");
X    k_1start    = xlenter(":START1");
X    k_1end    = xlenter(":END1");
X    k_2start    = xlenter(":START2");
X    k_2end    = xlenter(":END2");
X    k_verbose    = xlenter(":VERBOSE");
X    k_print    = xlenter(":PRINT");
X    k_count    = xlenter(":COUNT");
X    k_key    = xlenter(":KEY");
X
X    /* enter lambda list keywords */
X    lk_optional    = xlenter("&OPTIONAL");
X    lk_rest    = xlenter("&REST");
X    lk_key    = xlenter("&KEY");
X    lk_aux    = xlenter("&AUX");
X    lk_allow_other_keys = xlenter("&ALLOW-OTHER-KEYS");
X
X    /* enter *standard-input*, *standard-output* and *error-output* */
X    s_stdin = xlenter("*STANDARD-INPUT*");
X    setvalue(s_stdin,cvfile(stdin));
X    s_stdout = xlenter("*STANDARD-OUTPUT*");
X    setvalue(s_stdout,cvfile(stdout));
X    s_stderr = xlenter("*ERROR-OUTPUT*");
X    setvalue(s_stderr,cvfile(stderr));
X
X    /* enter *debug-io* and *trace-output* */
X    s_debugio = xlenter("*DEBUG-IO*");
X    setvalue(s_debugio,getvalue(s_stderr));
X    s_traceout = xlenter("*TRACE-OUTPUT*");
X    setvalue(s_traceout,getvalue(s_stderr));
X
X    /* enter the eval and apply hook variables */
X    s_evalhook = xlenter("*EVALHOOK*");
X    s_applyhook = xlenter("*APPLYHOOK*");
X
X    /* enter the symbol pointing to the list of functions being traced */
X    s_tracelist = xlenter("*TRACELIST*");
X
X    /* enter the error traceback and the error break enable flags */
X    s_tracenable = xlenter("*TRACENABLE*");
X    s_tlimit = xlenter("*TRACELIMIT*");
X    s_breakenable = xlenter("*BREAKENABLE*");
X
X    /* enter a symbol to control printing of garbage collection messages */
X    s_gcflag = xlenter("*GC-FLAG*");
X    s_gchook = xlenter("*GC-HOOK*");
X
X    /* enter a copyright notice into the oblist */
X    sym = xlenter("**Copyright-1988-by-David-Betz**");
X    setvalue(sym,true);
X
X    /* enter type names */
X    a_subr    = xlenter("SUBR");
X    a_fsubr    = xlenter("FSUBR");
X    a_cons    = xlenter("CONS");
X    a_symbol    = xlenter("SYMBOL");
X    a_fixnum    = xlenter("FIXNUM");
X    a_flonum    = xlenter("FLONUM");
X    a_string    = xlenter("STRING");
X    a_object    = xlenter("OBJECT");
X    a_stream    = xlenter("FILE-STREAM");
X    a_vector    = xlenter("ARRAY");
X    a_closure    = xlenter("CLOSURE");
X    a_char      = xlenter("CHARACTER");
X    a_ustream    = xlenter("UNNAMED-STREAM");
X
X    /* add the object-oriented programming symbols and os specific stuff */
X    obsymbols();    /* object-oriented programming symbols */
X    ossymbols();    /* os specific symbols */
X}
X
SHAR_EOF
if test 7703 -ne "`wc -c 'xlinit.c'`"
then
    echo shar: error transmitting "'xlinit.c'" '(should have been 7703 characters)'
fi
echo shar: extracting "'xlio.c'" '(4057 characters)'
if test -f 'xlio.c'
then
    echo shar: over-writing existing file "'xlio.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlio.c'
X/* xlio - xlisp i/o routines */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL s_stdin,s_stdout,s_stderr,s_debugio,s_traceout,s_unbound;
Xextern int xlfsize;
X
X/* xlgetc - get a character from a file or stream */
Xint xlgetc(fptr)
X  LVAL fptr;
X{
X    LVAL lptr,cptr;
X    FILE *fp;
X    int ch;
X
X    /* check for input from nil */
X    if (fptr == NIL)
X    ch = EOF;
X
X    /* otherwise, check for input from a stream */
X    else if (ustreamp(fptr)) {
X    if ((lptr = gethead(fptr)) == NIL)
X        ch = EOF;
X    else {
X        if (!consp(lptr) || (cptr = car(lptr)) == NIL || !charp(cptr))
X        xlfail("bad stream");
X        sethead(fptr,lptr = cdr(lptr));
X        if (lptr == NIL)
X        settail(fptr,NIL);
X        ch = getchcode(cptr);
X    }
X    }
X
X    /* otherwise, check for a buffered character */
X    else if (ch = getsavech(fptr))
X    setsavech(fptr,'\0');
X
X    /* otherwise, check for terminal input or file input */
X    else {
X    fp = getfile(fptr);
X    if (fp == stdin || fp == stderr)
X        ch = ostgetc();
X    else
X        ch = osagetc(fp);
X    }
X
X    /* return the character */
X    return (ch);
X}
X
X/* xlungetc - unget a character */
Xxlungetc(fptr,ch)
X  LVAL fptr; int ch;
X{
X    LVAL lptr;
X
X    /* check for ungetc from nil */
X    if (fptr == NIL)
X    ;
X
X    /* otherwise, check for ungetc to a stream */
X    if (ustreamp(fptr)) {
X    if (ch != EOF) {
X        lptr = cons(cvchar(ch),gethead(fptr));
X        if (gethead(fptr) == NIL)
X        settail(fptr,lptr);
X        sethead(fptr,lptr);
X    }
X    }
X
X    /* otherwise, it must be a file */
X    else
X    setsavech(fptr,ch);
X}
X
X/* xlpeek - peek at a character from a file or stream */
Xint xlpeek(fptr)
X  LVAL fptr;
X{
X    LVAL lptr,cptr;
X    int ch;
X
X    /* check for input from nil */
X    if (fptr == NIL)
X    ch = EOF;
X
X    /* otherwise, check for input from a stream */
X    else if (ustreamp(fptr)) {
X    if ((lptr = gethead(fptr)) == NIL)
X        ch = EOF;
X    else {
X        if (!consp(lptr) || (cptr = car(lptr)) == NIL || !charp(cptr))
X        xlfail("bad stream");
X        ch = getchcode(cptr);
X    }
X    }
X
X    /* otherwise, get the next file character and save it */
X    else {
X    ch = xlgetc(fptr);
X    setsavech(fptr,ch);
X    }
X
X    /* return the character */
X    return (ch);
X}
X
X/* xlputc - put a character to a file or stream */
Xxlputc(fptr,ch)
X  LVAL fptr; int ch;
X{
X    LVAL lptr;
X    FILE *fp;
X
X    /* count the character */
X    ++xlfsize;
X
X    /* check for output to nil */
X    if (fptr == NIL)
X    ;
X
X    /* otherwise, check for output to an unnamed stream */
X    else if (ustreamp(fptr)) {
X    lptr = consa(cvchar(ch));
X    if (gettail(fptr))
X        rplacd(gettail(fptr),lptr);
X    else
X        sethead(fptr,lptr);
X    settail(fptr,lptr);
X    }
X
X    /* otherwise, check for terminal output or file output */
X    else {
X    fp = getfile(fptr);
X    if (fp == stdout || fp == stderr)
X        ostputc(ch);
X    else
X        osaputc(ch,fp);
X    }
X}
X
X/* xlflush - flush the input buffer */
Xint xlflush()
X{
X    osflush();
X}
X
X/* stdprint - print to *standard-output* */
Xstdprint(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_stdout),expr,TRUE);
X    xlterpri(getvalue(s_stdout));
X}
X
X/* stdputstr - print a string to *standard-output* */
Xstdputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_stdout),str);
X}
X
X/* errprint - print to *error-output* */
Xerrprint(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_stderr),expr,TRUE);
X    xlterpri(getvalue(s_stderr));
X}
X
X/* errputstr - print a string to *error-output* */
Xerrputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_stderr),str);
X}
X
X/* dbgprint - print to *debug-io* */
Xdbgprint(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_debugio),expr,TRUE);
X    xlterpri(getvalue(s_debugio));
X}
X
X/* dbgputstr - print a string to *debug-io* */
Xdbgputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_debugio),str);
X}
X
X/* trcprin1 - print to *trace-output* */
Xtrcprin1(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_traceout),expr,TRUE);
X}
X
X/* trcputstr - print a string to *trace-output* */
Xtrcputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_traceout),str);
X}
X
X
SHAR_EOF
if test 4057 -ne "`wc -c 'xlio.c'`"
then
    echo shar: error transmitting "'xlio.c'" '(should have been 4057 characters)'
fi
echo shar: extracting "'xlisp.c'" '(3657 characters)'
if test -f 'xlisp.c'
then
    echo shar: over-writing existing file "'xlisp.c'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.c'
X/* xlisp.c - a small implementation of lisp with object-oriented programming */
X/*    Copyright (c) 1987, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xlisp.h"
X
X/* define the banner line string */
X#define BANNER    "XLISP version 2.1, Copyright (c) 1989, by David Betz"
X
X/* global variables */
Xjmp_buf top_level;
X
X/* external variables */
Xextern LVAL s_stdin,s_evalhook,s_applyhook;
Xextern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
Xextern int xltrcindent;
Xextern int xldebug;
Xextern LVAL true;
Xextern char buf[];
Xextern FILE *tfp;
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* main - the main routine */
Xmain(argc,argv)
X  int argc; char *argv[];
X{
X    char *transcript;
X    CONTEXT cntxt;
X    int verbose,i;
X    LVAL expr;
X
X    /* setup default argument values */
X    transcript = NULL;
X    verbose = FALSE;
X
X    /* parse the argument list switches */
X#ifndef LSC
X    for (i = 1; i < argc; ++i)
X    if (argv[i][0] == '-')
X        switch(argv[i][1]) {
X        case 't':
X        case 'T':
X        transcript = &argv[i][2];
X        break;
X        case 'v':
X        case 'V':
X        verbose = TRUE;
X        break;
X        }
X#endif
X
X    /* initialize and print the banner line */
X    osinit(BANNER);
X
X    /* setup initialization error handler */
X    xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
X    if (setjmp(cntxt.c_jmpbuf))
X    xlfatal("fatal initialization error");
X    if (setjmp(top_level))
X    xlfatal("RESTORE not allowed during initialization");
X
X    /* initialize xlisp */
X    xlinit();
X    xlend(&cntxt);
X
X    /* reset the error handler */
X    xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
X
X    /* open the transcript file */
X    if (transcript && (tfp = osaopen(transcript,"w")) == NULL) {
X    sprintf(buf,"error: can't open transcript file: %s",transcript);
X    stdputstr(buf);
X    }
X
X    /* load "init.lsp" */
X    if (setjmp(cntxt.c_jmpbuf) == 0)
X    xlload("init.lsp",TRUE,FALSE);
X
X    /* load any files mentioned on the command line */
X    if (setjmp(cntxt.c_jmpbuf) == 0)
X    for (i = 1; i < argc; i++)
X        if (argv[i][0] != '-' && !xlload(argv[i],TRUE,verbose))
X        xlerror("can't load file",cvstring(argv[i]));
X
X    /* target for restore */
X    if (setjmp(top_level))
X    xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
X
X    /* protect some pointers */
X    xlsave1(expr);
X
X    /* main command processing loop */
X    for (;;) {
X
X    /* setup the error return */
X    if (setjmp(cntxt.c_jmpbuf)) {
X        setvalue(s_evalhook,NIL);
X        setvalue(s_applyhook,NIL);
X        xltrcindent = 0;
X        xldebug = 0;
X        xlflush();
X    }
X
X    /* print a prompt */
X    stdputstr("> ");
X
X    /* read an expression */
X    if (!xlread(getvalue(s_stdin),&expr,FALSE))
X        break;
X
X    /* save the input expression */
X    xlrdsave(expr);
X
X    /* evaluate the expression */
X    expr = xleval(expr);
X
X    /* save the result */
X    xlevsave(expr);
X
X    /* print it */
X    stdprint(expr);
X    }
X    xlend(&cntxt);
X
X    /* clean up */
X    wrapup();
X}
X
X/* xlrdsave - save the last expression returned by the reader */
Xxlrdsave(expr)
X  LVAL expr;
X{
X    setvalue(s_3plus,getvalue(s_2plus));
X    setvalue(s_2plus,getvalue(s_1plus));
X    setvalue(s_1plus,getvalue(s_minus));
X    setvalue(s_minus,expr);
X}
X
X/* xlevsave - save the last expression returned by the evaluator */
Xxlevsave(expr)
X  LVAL expr;
X{
X    setvalue(s_3star,getvalue(s_2star));
X    setvalue(s_2star,getvalue(s_1star));
X    setvalue(s_1star,expr);
X}
X
X/* xlfatal - print a fatal error message and exit */
Xxlfatal(msg)
X  char *msg;
X{
X    oserror(msg);
X    wrapup();
X}
X
X/* wrapup - clean up and exit to the operating system */
Xwrapup()
X{
X    if (tfp)
X    osclose(tfp);
X    osfinish();
X    exit(0);
X}
X
SHAR_EOF
if test 3657 -ne "`wc -c 'xlisp.c'`"
then
    echo shar: error transmitting "'xlisp.c'" '(should have been 3657 characters)'
fi
echo shar: extracting "'xlisp.h'" '(9630 characters)'
if test -f 'xlisp.h'
then
    echo shar: over-writing existing file "'xlisp.h'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.h'
X/* xlisp - a small subset of lisp */
X/*    Copyright (c) 1985, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X/* system specific definitions */
X#define _TURBOC_
X
X#include <stdio.h>
X#include <ctype.h>
X#include <setjmp.h>
X
X/* NNODES    number of nodes to allocate in each request (1000) */
X/* EDEPTH    evaluation stack depth (2000) */
X/* ADEPTH    argument stack depth (1000) */
X/* FORWARD    type of a forward declaration () */
X/* LOCAL    type of a local function (static) */
X/* AFMT        printf format for addresses ("%x") */
X/* FIXTYPE    data type for fixed point numbers (long) */
X/* ITYPE    fixed point input conversion routine type (long atol()) */
X/* ICNV        fixed point input conversion routine (atol) */
X/* IFMT        printf format for fixed point numbers ("%ld") */
X/* FLOTYPE    data type for floating point numbers (float) */
X/* OFFTYPE    number the size of an address (int) */
X
X/* for the Turbo C compiler - MS-DOS, large model */
X#ifdef _TURBOC_
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - MS-DOS, large model */
X#ifdef AZTEC_LM
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define CVPTR(x)    ptrtoabs(x)
X#define NIL        (void *)0
Xextern long ptrtoabs();
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - Macintosh */
X#ifdef AZTEC_MAC
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define NIL        (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the AZTEC C compiler - Amiga */
X#ifdef AZTEC_AMIGA
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define NIL        (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the Lightspeed C compiler - Macintosh */
X#ifdef LSC
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#define NIL        (void *)0
X#define SAVERESTORE
X#endif
X
X/* for the Microsoft C compiler - MS-DOS, large model */
X#ifdef MSC
X#define NNODES        2000
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#endif
X
X/* for the Mark Williams C compiler - Atari ST */
X#ifdef MWC
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#endif
X
X/* for the Lattice C compiler - Atari ST */
X#ifdef LATTICE
X#define FIXTYPE        int
X#define ITYPE        int atoi()
X#define ICNV(n)        atoi(n)
X#define IFMT        "%d"
X#endif
X
X/* for the Digital Research C compiler - Atari ST */
X#ifdef DR
X#define LOCAL
X#define AFMT        "%lx"
X#define OFFTYPE        long
X#undef NULL
X#define NULL        0L
X#endif
X
X/* default important definitions */
X#ifndef NNODES
X#define NNODES        1000
X#endif
X#ifndef EDEPTH
X#define EDEPTH        2000
X#endif
X#ifndef ADEPTH
X#define ADEPTH        1000
X#endif
X#ifndef FORWARD
X#define FORWARD
X#endif
X#ifndef LOCAL
X#define LOCAL        static
X#endif
X#ifndef AFMT
X#define AFMT        "%x"
X#endif
X#ifndef FIXTYPE
X#define FIXTYPE        long
X#endif
X#ifndef ITYPE
X#define ITYPE        long atol()
X#endif
X#ifndef ICNV
X#define ICNV(n)        atol(n)
X#endif
X#ifndef IFMT
X#define IFMT        "%ld"
X#endif
X#ifndef FLOTYPE
X#define FLOTYPE        double
X#endif
X#ifndef OFFTYPE
X#define OFFTYPE        int
X#endif
X#ifndef CVPTR
X#define CVPTR(x)    (x)
X#endif
X#ifndef UCHAR
X#define UCHAR        unsigned char
X#endif
X
X/* useful definitions */
X#define TRUE    1
X#define FALSE    0
X#ifndef NIL
X#define NIL    (LVAL )0
X#endif
X
X/* include the dynamic memory definitions */
X#include "xldmem.h"
X
X/* program limits */
X#define STRMAX        100        /* maximum length of a string constant */
X#define HSIZE        199        /* symbol hash table size */
X#define SAMPLE        100        /* control character sample rate */
X
X/* function table offsets for the initialization functions */
X#define FT_RMHASH    0
X#define FT_RMQUOTE    1
X#define FT_RMDQUOTE    2
X#define FT_RMBQUOTE    3
X#define FT_RMCOMMA    4
X#define FT_RMLPAR    5
X#define FT_RMRPAR    6
X#define FT_RMSEMI    7
X#define FT_CLNEW    10
X#define FT_CLISNEW    11
X#define FT_CLANSWER    12
X#define FT_OBISNEW    13
X#define FT_OBCLASS    14
X#define FT_OBSHOW    15
X
X/* macro to push a value onto the argument stack */
X#define pusharg(x)    {if (xlsp >= xlargstktop) xlargstkoverflow();\
X             *xlsp++ = (x);}
X
X/* macros to protect pointers */
X#define xlstkcheck(n)    {if (xlstack - (n) < xlstkbase) xlstkoverflow();}
X#define xlsave(n)    {*--xlstack = &n; n = NIL;}
X#define xlprotect(n)    {*--xlstack = &n;}
X
X/* check the stack and protect a single pointer */
X#define xlsave1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
X                         *--xlstack = &n; n = NIL;}
X#define xlprot1(n)    {if (xlstack <= xlstkbase) xlstkoverflow();\
X                         *--xlstack = &n;}
X
X/* macros to pop pointers off the stack */
X#define xlpop()        {++xlstack;}
X#define xlpopn(n)    {xlstack+=(n);}
X
X/* macros to manipulate the lexical environment */
X#define xlframe(e)    cons(NIL,e)
X#define xlbind(s,v)    xlpbind(s,v,xlenv)
X#define xlfbind(s,v)    xlpbind(s,v,xlfenv);
X#define xlpbind(s,v,e)    {rplaca(e,cons(cons(s,v),car(e)));}
X
X/* macros to manipulate the dynamic environment */
X#define xldbind(s,v)    {xldenv = cons(cons(s,getvalue(s)),xldenv);\
X             setvalue(s,v);}
X#define xlunbind(e)    {for (; xldenv != (e); xldenv = cdr(xldenv))\
X               setvalue(car(car(xldenv)),cdr(car(xldenv)));}
X
X/* type predicates */
X#define atom(x)        ((x) == NIL || ntype(x) != CONS)
X#define null(x)        ((x) == NIL)
X#define listp(x)    ((x) == NIL || ntype(x) == CONS)
X#define consp(x)    ((x) && ntype(x) == CONS)
X#define subrp(x)    ((x) && ntype(x) == SUBR)
X#define fsubrp(x)    ((x) && ntype(x) == FSUBR)
X#define stringp(x)    ((x) && ntype(x) == STRING)
X#define symbolp(x)    ((x) && ntype(x) == SYMBOL)
X#define streamp(x)    ((x) && ntype(x) == STREAM)
X#define objectp(x)    ((x) && ntype(x) == OBJECT)
X#define fixp(x)        ((x) && ntype(x) == FIXNUM)
X#define floatp(x)    ((x) && ntype(x) == FLONUM)
X#define vectorp(x)    ((x) && ntype(x) == VECTOR)
X#define closurep(x)    ((x) && ntype(x) == CLOSURE)
X#define charp(x)    ((x) && ntype(x) == CHAR)
X#define ustreamp(x)    ((x) && ntype(x) == USTREAM)
X#define structp(x)    ((x) && ntype(x) == STRUCT)
X#define boundp(x)    (getvalue(x) != s_unbound)
X#define fboundp(x)    (getfunction(x) != s_unbound)
X
X/* shorthand functions */
X#define consa(x)    cons(x,NIL)
X#define consd(x)    cons(NIL,x)
X
X/* argument list parsing macros */
X#define xlgetarg()    (testarg(nextarg()))
X#define xllastarg()    {if (xlargc != 0) xltoomany();}
X#define testarg(e)    (moreargs() ? (e) : xltoofew())
X#define typearg(tp)    (tp(*xlargv) ? nextarg() : xlbadtype(*xlargv))
X#define nextarg()    (--xlargc, *xlargv++)
X#define moreargs()    (xlargc > 0)
X
X/* macros to get arguments of a particular type */
X#define xlgacons()    (testarg(typearg(consp)))
X#define xlgalist()    (testarg(typearg(listp)))
X#define xlgasymbol()    (testarg(typearg(symbolp)))
X#define xlgastring()    (testarg(typearg(stringp)))
X#define xlgaobject()    (testarg(typearg(objectp)))
X#define xlgafixnum()    (testarg(typearg(fixp)))
X#define xlgaflonum()    (testarg(typearg(floatp)))
X#define xlgachar()    (testarg(typearg(charp)))
X#define xlgavector()    (testarg(typearg(vectorp)))
X#define xlgastream()    (testarg(typearg(streamp)))
X#define xlgaustream()    (testarg(typearg(ustreamp)))
X#define xlgaclosure()    (testarg(typearg(closurep)))
X#define xlgastruct()    (testarg(typearg(structp)))
X
X/* function definition structure */
Xtypedef struct {
X    char *fd_name;    /* function name */
X    int fd_type;    /* function type */
X    LVAL (*fd_subr)();    /* function entry point */
X} FUNDEF;
X
X/* execution context flags */
X#define CF_GO        0x0001
X#define CF_RETURN    0x0002
X#define CF_THROW    0x0004
X#define CF_ERROR    0x0008
X#define CF_CLEANUP    0x0010
X#define CF_CONTINUE    0x0020
X#define CF_TOPLEVEL    0x0040
X#define CF_BRKLEVEL    0x0080
X#define CF_UNWIND    0x0100
X
X/* execution context */
Xtypedef struct context {
X    int c_flags;            /* context type flags */
X    LVAL c_expr;            /* expression (type dependant) */
X    jmp_buf c_jmpbuf;            /* longjmp context */
X    struct context *c_xlcontext;    /* old value of xlcontext */
X    LVAL **c_xlstack;            /* old value of xlstack */
X    LVAL *c_xlargv;            /* old value of xlargv */
X    int c_xlargc;            /* old value of xlargc */
X    LVAL *c_xlfp;            /* old value of xlfp */
X    LVAL *c_xlsp;            /* old value of xlsp */
X    LVAL c_xlenv;            /* old value of xlenv */
X    LVAL c_xlfenv;            /* old value of xlfenv */
X    LVAL c_xldenv;            /* old value of xldenv */
X} CONTEXT;
X
X/* external variables */
Xextern LVAL **xlstktop;           /* top of the evaluation stack */
Xextern LVAL **xlstkbase;    /* base of the evaluation stack */
Xextern LVAL **xlstack;        /* evaluation stack pointer */
Xextern LVAL *xlargstkbase;    /* base of the argument stack */
Xextern LVAL *xlargstktop;    /* top of the argument stack */
Xextern LVAL *xlfp;        /* argument frame pointer */
Xextern LVAL *xlsp;        /* argument stack pointer */
Xextern LVAL *xlargv;        /* current argument vector */
Xextern int xlargc;        /* current argument count */
X
X/* external procedure declarations */
Xextern LVAL xleval();        /* evaluate an expression */
Xextern LVAL xlapply();        /* apply a function to arguments */
Xextern LVAL xlsubr();        /* enter a subr/fsubr */
Xextern LVAL xlenter();        /* enter a symbol */
Xextern LVAL xlmakesym();    /* make an uninterned symbol */
Xextern LVAL xlgetvalue();    /* get value of a symbol (checked) */
Xextern LVAL xlxgetvalue();    /* get value of a symbol */
Xextern LVAL xlgetfunction();    /* get functional value of a symbol */
Xextern LVAL xlxgetfunction();    /* get functional value of a symbol (checked) */
Xextern LVAL xlexpandmacros();    /* expand macros in a form */
Xextern LVAL xlgetprop();    /* get the value of a property */
Xextern LVAL xlclose();        /* create a function closure */
X
X/* argument list parsing functions */
Xextern LVAL xlgetfile();          /* get a file/stream argument */
Xextern LVAL xlgetfname();    /* get a filename argument */
X
X/* error reporting functions (don't *really* return at all) */
Xextern LVAL xltoofew();        /* report "too few arguments" error */
Xextern LVAL xlbadtype();    /* report "bad argument type" error */
X
SHAR_EOF
if test 9630 -ne "`wc -c 'xlisp.h'`"
then
    echo shar: error transmitting "'xlisp.h'" '(should have been 9630 characters)'
fi
echo shar: extracting "'xlisp.lnk'" '(267 characters)'
if test -f 'xlisp.lnk'
then
    echo shar: over-writing existing file "'xlisp.lnk'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.lnk'
Xc:\turboc\lib\c0l.obj +
Xxlisp xlbfun xlcont xldbug xldmem xleval xlfio +
Xxlftab xlglob xlimage xlinit xlio xljump xllist    +
Xxlmath xlobj xlpp xlprin xlread xlstr xlstruct +
Xxlsubr xlsym xlsys msstuff
Xxlisp
Xxlisp
Xc:\turboc\lib\emu c:\turboc\lib\mathl c:\turboc\lib\cl
X
SHAR_EOF
if test 267 -ne "`wc -c 'xlisp.lnk'`"
then
    echo shar: error transmitting "'xlisp.lnk'" '(should have been 267 characters)'
fi
echo shar: extracting "'xlisp.mac'" '(27375 characters)'
if test -f 'xlisp.mac'
then
    echo shar: over-writing existing file "'xlisp.mac'"
fi
sed 's/^X//' << \SHAR_EOF > 'xlisp.mac'
XFrom sce!mitel!uunet!datapg!com50!pai!erc Tue Nov 14 08:51:33 EST 1989
XArticle: 753 of comp.lang.scheme
XPath: cognos!sce!mitel!uunet!datapg!com50!pai!erc
XFrom: [e-mail] (Eric Johnson)
XNewsgroups: comp.lang.scheme,comp.sys.mac
XSubject: Re: How to build xscheme for the mac
XSummary: Hope this helps...
XKeywords: xscheme, mac
XMessage-ID: <[e-mail]>
XDate: 11 Nov 89 18:55:05 GMT
XReferences: <[e-mail]>
XOrganization: Prime Automation, Inc., Burnsville, MN
XLines: 1374
XXref: cognos comp.lang.scheme:753 comp.sys.mac:33459
X
XIn article <[e-mail]>, [e-mail] (Paul Puglia) writes:
X> How does you build xscheme on a macintosh ? I have a copy of
X> the xscheme sources compiles fine on a unix machine, and works
X> great on a pc with turbo c.  When I tried to compile it on a
X> friends mac II using his copy of lightspeed c. I have no luck.
X> Could someone please describe the procedure to compile this program, and
X> comment on if anything else is need to compile xscheme. I know that you
X> need some resource to compile xlisp on a mac. Do you need the same sort of
X> stuff for xscheme
X> Thanks in advance
X> Paul Puglia
X> Dept of Civil Engineering
X> Columbia University
X
X
X
XPorting Xlisp/XScheme:
X
XAwhile back, while I was taking an AI course, I was spending a lot of time
Xtrekking to campus and using their LISP system.  To avoid travel time (and
Xto work on LISP at any hour I wanted), I got into porting XLisp. In looking at
Xthe code, I'd say XLisp and XScheme are two of the most portable C programs
XI have ever seen.  Now, I've spent most of my time on XLisp, so your
Xmileage may vary, but...
X
XXLisp seems to place most Operating System (OS)-dependent features in
Xseparate files, named dosstuff.c, osptrs.h, osdefs.h.  On UNIX, the "stuff:
Xfile is called unixstuf.c and on the Mac its called macstuff.c (all file
Xnames are <= 8 chars for MS-DOS).  The mac version also has a resource
Xcompiler file (that is, a file you run through the resource compiler to
Xgenerate a resource file).
X
XI assume (hope) XScheme is similiar.  Below, I placed all my Mac-related
Xfiles from XLisp (2.0, I think).  The XScheme stuff should be similiar.
XI hope these help.  (Note: I don't have the full sources around now, just
Xthe Mac and UNIX-specific files.)  (Note2: Two extra files, macfun.c and
Xmacinit.c are below, its been so long that I'm not sure if these are extras
Xor necessary--Sorry.)
X
XI'm placing these files here in hopes they can help you with your porting.  I
Xdo know that binary executable versions of XScheme are available on the
XBIX bulletin board (Byte magazine Information eXchange)--see Byte mag
Xfor details.  Getting the binaries would solve all the Mac porting
Xproblems in one fell swoop.
X
XAnyway, hope this helps,
X-Eric
X
X
X======================== macfun.c =============================================
X
X/* macfun.c - macintosh user interface functions for xlisp */
X
X#include <Quickdraw.h>
X#include <WindowMgr.h>
X#include <MemoryMgr.h>
X#include "xlisp.h"
X
X/* external variables */
Xextern GrafPtr cwindow,gwindow;
X
X/* forward declarations */
XFORWARD LVAL do_0();
XFORWARD LVAL do_1();
XFORWARD LVAL do_2();
X
X/* xptsize - set the command window point size */
XLVAL xptsize()
X{
X    LVAL val;
X    val = xlgafixnum();
X    xllastarg();
X    TextSize((int)getfixnum(val));
X    InvalRect(&cwindow->portRect);
X    SetupScreen();
X    return (NIL);
X}
X
X/* xhidepen - hide the pen */
XLVAL xhidepen()
X{
X    return (do_0('H'));
X}
X
X/* xshowpen - show the pen */
XLVAL xshowpen()
X{
X    return (do_0('S'));
X}
X
X/* xgetpen - get the pen position */
XLVAL xgetpen()
X{
X    LVAL val;
X    Point p;
X    xllastarg();
X    SetPort(gwindow);
X    GetPen(&p);
X    SetPort(cwindow);
X    xlsave1(val);
X    val = consa(NIL);
X    rplaca(val,cvfixnum((FIXTYPE)p.h));
X    rplacd(val,cvfixnum((FIXTYPE)p.v));
X    xlpop();
X    return (val);
X}
X
X/* xpenmode - set the pen mode */
XLVAL xpenmode()
X{
X    return (do_1('M'));
X}
X
X/* xpensize - set the pen size */
XLVAL xpensize()
X{
X    return (do_2('S'));
X}
X
X/* xpenpat - set the pen pattern */
XLVAL xpenpat()
X{
X    LVAL plist;
X    char pat[8],i;
X    plist = xlgalist();
X    xllastarg();
X    for (i = 0; i < 8 && consp(plist); ++i, plist = cdr(plist))
X    if (fixp(car(plist)))
X        pat[i] = getfixnum(car(plist));
X    SetPort(gwindow);
X    PenPat(pat);
X    SetPort(cwindow);
X    return (NIL);
X}
X
X/* xpennormal - set the pen to normal */
XLVAL xpennormal()
X{
X    xllastarg();
X    SetPort(gwindow);
X    PenNormal();
X    SetPort(cwindow);
X    return (NIL);
X}
X
X/* xmoveto - Move to a screen location */
XLVAL xmoveto()
X{
X    return (do_2('m'));
X}
X
X/* xmove - Move in a specified direction */
XLVAL xmove()
X{
X    return (do_2('M'));
X}
X
X/* xlineto - draw a Line to a screen location */
XLVAL xlineto()
X{
X    return (do_2('l'));
X}
X
X/* xline - draw a Line in a specified direction */
XLVAL xline()
X{
X    return (do_2('L'));
X}
X
X/* xshowgraphics - show the graphics window */
XLVAL xshowgraphics()
X{
X    xllastarg();
X    scrsplit(1);
X    return (NIL);
X}
X
X/* xhidegraphics - hide the graphics window */
XLVAL xhidegraphics()
X{
X    xllastarg();
X    scrsplit(0);
X    return (NIL);
X}
X
X/* xcleargraphics - clear the graphics window */
XLVAL xcleargraphics()
X{
X    xllastarg();
X    SetPort(gwindow);
X    EraseRect(&gwindow->portRect);
X    SetPort(cwindow);
X    return (NIL);
X}
X
X/* do_0 - Handle commands that require no arguments */
XLOCAL LVAL do_0(fcn)
X  int fcn;
X{
X    xllastarg();
X    SetPort(gwindow);
X    switch (fcn) {
X    case 'H':    HidePen(); break;
X    case 'S':    ShowPen(); break;
X    }
X    SetPort(cwindow);
X    return (NIL);
X}
X
X/* do_1 - Handle commands that require one integer argument */
XLOCAL LVAL do_1(fcn)
X  int fcn;
X{
X    int x;
X    x = getnumber();
X    xllastarg();
X    SetPort(gwindow);
X    switch (fcn) {
X    case 'M':    PenMode(x); break;
X    }
X    SetPort(cwindow);
X    return (NIL);
X}
X
X/* do_2 - Handle commands that require two integer arguments */
XLOCAL LVAL do_2(fcn)
X  int fcn;
X{
X    int h,v;
X    h = getnumber();
X    v = getnumber();
X    xllastarg();
X    SetPort(gwindow);
X    switch (fcn) {
X    case 'l':    LineTo(h,v); break;
X    case 'L':    Line(h,v);   break;
X    case 'm':   MoveTo(h,v); break;
X    case 'M':    Move(h,v);   break;
X    case 'S':    PenSize(h,v);break;
X    }
X    SetPort(cwindow);
X    return (NIL);
X}
X
X/* getnumber - get an integer parameter */
XLOCAL int getnumber()
X{
X    LVAL num;
X    num = xlgafixnum();
X    return ((int)getfixnum(num));
X}
X
X/* xtool - call the toolbox */
XLVAL xtool()
X{
X    LVAL val;
X    int trap;
X
X    trap = getnumber();
X/*
X
X    asm {
X    move.l    args(A6),D0
X    beq    L2
XL1:    move.l    D0,A0
X    move.l    2(A0),A1
X    move.w    4(A1),-(A7)
X    move.l    6(A0),D0
X    bne    L1
XL2:    lea    L3,A0
X    move.w    trap(A6),(A0)
XL3:    dc.w    0xA000
X    clr.l    val(A6)
X    }
X*/
X
X    return (val);
X}
X
X/* xtool16 - call the toolbox with a 16 bit result */
XLVAL xtool16()
X{
X    int trap,val;
X
X    trap = getnumber();
X/*
X
X    asm {
X    clr.w    -(A7)
X    move.l    args(A6),D0
X    beq    L2
XL1:    move.l    D0,A0
X    move.l    2(A0),A1
X    move.w    4(A1),-(A7)
X    move.l    6(A0),D0
X    bne    L1
XL2:    lea    L3,A0
X    move.w    trap(A6),(A0)
XL3:    dc.w    0xA000
X    move.w    (A7)+,val(A6)
X    }
X*/
X
X    return (cvfixnum((FIXTYPE)val));
X}
X
X/* xtool32 - call the toolbox with a 32 bit result */
XLVAL xtool32()
X{
X    int trap;
X    long val;
X
X    trap = getnumber();
X/*
X
X    asm {
X    clr.l    -(A7)
X    move.l    args(A6),D0
X    beq    L2
XL1:    move.l    D0,A0
X    move.l    2(A0),A1
X    move.w    4(A1),-(A7)
X    move.l    6(A0),D0
X    bne    L1
XL2:    lea    L3,A0
X    move.w    trap(A6),(A0)
XL3:    dc.w    0xA000
X    move.l    (A7)+,val(A6)
X    }
X*/
X
X    return (cvfixnum((FIXTYPE)val));
X}
X
X/* xnewhandle - allocate a new handle */
XLVAL xnewhandle()
X{
X    LVAL num;
X    long size;
X    num = xlgafixnum(); size = getfixnum(num);
X    xllastarg();
X    return (cvfixnum((FIXTYPE)NewHandle(size)));
X}
X
X/* xnewptr - allocate memory */
XLVAL xnewptr()
X{
X    LVAL num;
X    long size;
X    num = xlgafixnum(); size = getfixnum(num);
X    xllastarg();
X    return (cvfixnum((FIXTYPE)NewPtr(size)));
X}
X
X/* xhiword - return the high order 16 bits of an integer */
XLVAL xhiword()
X{
X    unsigned int val;
X    val = (unsigned int)(getnumber() >> 16);
X    xllastarg();
X    return (cvfixnum((FIXTYPE)val));
X}
X
X/* xloword - return the low order 16 bits of an integer */
XLVAL xloword()
X{
X    unsigned int val;
X    val = (unsigned int)getnumber();
X    xllastarg();
X    return (cvfixnum((FIXTYPE)val));
X}
X
X/* xrdnohang - get the next character in the look-ahead buffer */
XLVAL xrdnohang()
X{
X    int ch;
X    xllastarg();
X    if ((ch = scrnextc()) == EOF)
X    return (NIL);
X    return (cvfixnum((FIXTYPE)ch));
X}
X
X/* ossymbols - enter important symbols */
Xossymbols()
X{
X    LVAL sym;
X
X    /* setup globals for the window handles */
X    sym = xlenter("*COMMAND-WINDOW*");
X    setvalue(sym,cvfixnum((FIXTYPE)cwindow));
X    sym = xlenter("*GRAPHICS-WINDOW*");
X    setvalue(sym,cvfixnum((FIXTYPE)gwindow));
X}
X
X
X======================== macint.c =============================================
X
X/* macint.c - macintosh interface routines for xlisp */
X
X#include <MacTypes.h>
X#include <Quickdraw.h>
X#include <WindowMgr.h>
X#include <EventMgr.h>
X#include <DialogMgr.h>
X#include <MenuMgr.h>
X#include <PackageMgr.h>
X#include <StdFilePkg.h>
X#include <MemoryMgr.h>
X#include <DeskMgr.h>
X#include <FontMgr.h>
X#include <ControlMgr.h>
X#include <SegmentLdr.h>
X#include <FileMgr.h>
X
X/* program limits */
X#define SCRH        40    /* maximum screen height */
X#define SCRW        100    /* maximum screen width */
X#define CHARMAX     100    /* maximum number of buffered characters */
X#define TIMEON        40    /* cursor on time */
X#define TIMEOFF        20    /* cursor off time */
X
X/* useful definitions */
X#define MenuBarHeight    20
X#define TitleBarHeight    20
X#define SBarWidth    16
X#define MinWidth    80
X#define MinHeight    40
X#define ScreenMargin    2
X#define TextMargin    4
X#define GHeight        232
X
X/* menu id's */
X#define appleID        1
X#define fileID        256
X#define editID        257
X#define controlID    258
X
X/* externals */
Xextern char *s_unbound;
Xextern char *PtoCstr();
X
X/* screen dimensions */
Xint screenWidth;
Xint screenHeight;
X
X/* command window (normal screen) */
Xint nHorizontal,nVertical,nWidth,nHeight;
X
X/* command window (split screen) */
Xint sHorizontal,sVertical,sWidth,sHeight;
X
X/* graphics window */
Xint gHorizontal,gVertical,gWidth,gHeight;
X
X/* menu handles */
XMenuHandle appleMenu;
XMenuHandle fileMenu;
XMenuHandle editMenu;
XMenuHandle controlMenu;
X
X/* misc variables */
XOSType filetypes[] = { 'TEXT' };
X
X/* font information */
Xint tmargin,lmargin;
Xint xinc,yinc;
X
X/* command window */
XWindowRecord cwrecord;
XWindowPtr cwindow;
X
X/* graphics window */
XWindowRecord gwrecord;
XWindowPtr gwindow;
X
X/* window mode */
Xint splitmode;
X
X/* cursor variables */
Xlong cursortime;
Xint cursorstate;
Xint x,y;
X
X/* screen buffer */
Xchar screen[SCRH*SCRW],*topline,*curline;
Xint scrh,scrw;
X
X/* type ahead buffer */
Xchar charbuf[CHARMAX],*inptr,*outptr;
Xint charcnt;
X
Xmacinit()
X{
X    /* initialize the toolbox */
X    InitGraf(&thePort);
X    InitFonts();
X    InitWindows();
X    InitMenus();
X    TEInit();
X    InitDialogs(0L);
X    InitCursor();
X
X    /* setup the menu bar */
X    SetupMenus();
X
X    /* get the size of the screen */
X    screenWidth  = screenBits.bounds.right  - screenBits.bounds.left;
X    screenHeight = screenBits.bounds.bottom - screenBits.bounds.top;
X
X    /* Create the graphics and control windows */
X    gwindow = GetNewWindow(129,&gwrecord,-1L);
X    cwindow = GetNewWindow(128,&cwrecord,-1L);
X
X    /* establish the command window as the current port */
X    SetPort(cwindow);
X
X    /* compute the size of the normal command window */
X    nHorizontal = ScreenMargin;
X    nVertical = MenuBarHeight + TitleBarHeight + ScreenMargin - 2;
X    nWidth = screenWidth - (ScreenMargin * 2) - 1;
X    nHeight = screenHeight - MenuBarHeight - TitleBarHeight - (ScreenMargin * 2);
X
X    /* compute the size of the split command window */
X    sHorizontal = nHorizontal;
X    sVertical = nVertical + GHeight + 1;
X    sWidth = nWidth;
X    sHeight = nHeight - GHeight - 1;
X
X    /* compute the size of the graphics window */
X    gHorizontal = nHorizontal;
X    gVertical = MenuBarHeight + ScreenMargin;
X    gWidth = screenWidth - (ScreenMargin * 2);
X    gHeight = GHeight;
X
X    /* move and size the graphics window */
X    MoveWindow(gwindow,gHorizontal,gVertical,0);
X    SizeWindow(gwindow,gWidth,gHeight,0);
X
X    /* setup the font, size and writing mode for the command window */
X    TextFont(monaco); TextSize(9); TextMode(srcCopy);
X
X    /* setup command mode */
X    scrsplit(FALSE);
X
X    /* disable the Cursor */
X    cursorstate = -1;
X
X    /* setup the input ring buffer */
X    inptr = outptr = charbuf;
X    charcnt = 0;
X
X    /* lock the font in memory */
X    SetFontLock(-1);
X}
X
XSetupMenus()
X{
X    appleMenu = GetMenu(appleID);    /* setup the apple menu */
X    AddResMenu(appleMenu,'DRVR');
X    InsertMenu(appleMenu,0);
X    fileMenu = GetMenu(fileID);        /* setup the file menu */
X    InsertMenu(fileMenu,0);
X    editMenu = GetMenu(editID);        /* setup the edit menu */
X    InsertMenu(editMenu,0);
X    controlMenu = GetMenu(controlID);    /* setup the control menu */
X    InsertMenu(controlMenu,0);
X    DrawMenuBar();
X}
X
Xint scrgetc()
X{
X    CursorOn();
X    while (charcnt == 0)
X    DoEvent();
X    CursorOff();
X    return (scrnextc());
X}
X
Xint scrnextc()
X{
X    int ch;
X    if (charcnt > 0) {
X    ch = *outptr++; charcnt--;
X    if (outptr >= &charbuf[CHARMAX])
X        outptr = charbuf;
X    }
X    else {
X    charcnt = 0;
X    ch = -1;
X    }
X    return (ch);
X}
X
Xscrputc(ch)
X  int ch;
X{
X    switch (ch) {
X    case '\r':
X    x = 0;
X    break;
X    case '\n':
X    nextline(&curline);
X    if (++y >= scrh) {
X        y = scrh - 1;
X        scrollup();
X    }
X    break;
X    case '\t':
X    do { scrputc(' '); } while (x & 7);
X    break;
X    case '\010':
X    if (x) x--;
X    break;
X    default:
X    if (ch >= 0x20 && ch < 0x7F) {
X        scrposition(x,y);
X        DrawChar(ch);
X        curline[x] = ch;
X        if (++x >= scrw) {
X        nextline(&curline);
X        if (++y >= scrh) {
X            y = scrh - 1;
X            scrollup();
X        }
X        x = 0;
X        }
X    }
X    break;
X    }
X}
X
Xscrdelete()
X{
X    scrputc('\010');
X    scrputc(' ');
X    scrputc('\010');
X}
X
Xscrclear()
X{
X    curline = screen;
X    for (y = 0; y < SCRH; y++)
X    for (x = 0; x < SCRW; x++)
X        *curline++ = ' ';
X    topline = curline = screen;
X    x = y = 0;
X}
X
Xscrflush()
X{
X    inptr = outptr = charbuf;
X    charcnt = -1;
X    osflush();
X}
X
Xscrposition(x,y)
X  int x,y;
X{
X    MoveTo((x * xinc) + lmargin,(y * yinc) + tmargin);
X}
X
XDoEvent()
X{
X    EventRecord myEvent;
X
X    SystemTask();
X    CursorUpdate();
X
X    while (GetNextEvent(everyEvent,&myEvent))
X    switch (myEvent.what) {
X        case mouseDown:
X        DoMouseDown(&myEvent);
X        break;
X        case keyDown:
X        case autoKey:
X        DoKeyPress(&myEvent);
X        break;
X        case activateEvt:
X        DoActivate(&myEvent);
X        break;
X        case updateEvt:
X        DoUpdate(&myEvent);
X        break;
X        }
X}
X
XDoMouseDown(myEvent)
X  EventRecord *myEvent;
X{
X    WindowPtr whichWindow;
X
X    switch (FindWindow(myEvent->where,&whichWindow)) {
X    case inMenuBar:
X    DoMenuClick(myEvent);
X    break;
X    case inSysWindow:
X    SystemClick(myEvent,whichWindow);
X    break;
X    case inDrag:
X    DoDrag(myEvent,whichWindow);
X    break;
X    case inGoAway:
X    DoGoAway(myEvent,whichWindow);
X    break;
X    case inGrow:
X    DoGrow(myEvent,whichWindow);
X    break;
X    case inContent:
X    DoContent(myEvent,whichWindow);
X    break;
X    }
X}
X
XDoMenuClick(myEvent)
X  EventRecord *myEvent;
X{
X    long choice;
X    if (choice = MenuSelect(myEvent->where))
X    DoCommand(choice);
X}
X
XDoDrag(myEvent,whichWindow)
X  EventRecord *myEvent;
X  WindowPtr whichWindow;
X{
X    Rect dragRect;
X    SetRect(&dragRect,0,MenuBarHeight,screenWidth,screenHeight);
X    InsetRect(&dragRect,ScreenMargin,ScreenMargin);
X    DragWindow(whichWindow,myEvent->where,&dragRect);
X}
X
XDoGoAway(myEvent,whichWindow)
X  EventRecord *myEvent;
X  WindowPtr whichWindow;
X{
X    if (TrackGoAway(whichWindow,myEvent->where))
X    wrapup();
X}
X
XDoGrow(myEvent,whichWindow)
X  EventRecord *myEvent;
X  WindowPtr whichWindow;
X{
X    Rect sizeRect;
X    long newSize;
X    if (whichWindow != FrontWindow() && whichWindow != gwindow)
X    SelectWindow(whichWindow);
X    else {
X    SetRect(&sizeRect,MinWidth,MinHeight,screenWidth,screenHeight-MenuBarHeight);
X    newSize = GrowWindow(whichWindow,myEvent->where,&sizeRect);
X    if (newSize) {
X        EraseRect(&whichWindow->portRect);
X        SizeWindow(whichWindow,LoWord(newSize),HiWord(newSize),-1);
X        InvalRect(&whichWindow->portRect);
X        SetupScreen();
X        scrflush();
X    }
X    }
X}
X
XDoContent(myEvent,whichWindow)
X  EventRecord *myEvent;
X  WindowPtr whichWindow;
X{
X    if (whichWindow != FrontWindow() && whichWindow != gwindow)
X    SelectWindow(whichWindow);
X}
X
XDoKeyPress(myEvent)
X  EventRecord *myEvent;
X{
X    long choice;
X
X    if (FrontWindow() == cwindow) {
X    if (myEvent->modifiers & 0x100) {
X        if (choice = MenuKey((char)myEvent->message))
X        DoCommand(choice);
X    }
X    else {
X        if (charcnt < CHARMAX) {
X        *inptr++ = myEvent->message & 0xFF; charcnt++;
X        if (inptr >= &charbuf[CHARMAX])
X            inptr = charbuf;
X        }
X    }
X    }
X}
X
XDoActivate(myEvent)
X  EventRecord *myEvent;
X{
X    WindowPtr whichWindow;
X    whichWindow = (WindowPtr)myEvent->message;
X    SetPort(whichWindow);
X    if (whichWindow == cwindow)
X    DrawGrowIcon(whichWindow);
X}
X
XDoUpdate(myEvent)
X  EventRecord *myEvent;
X{
X    WindowPtr whichWindow;
X    GrafPtr savePort;
X    GetPort(&savePort);
X    whichWindow = (WindowPtr)myEvent->message;
X    SetPort(whichWindow);
X    BeginUpdate(whichWindow);
X    EraseRect(&whichWindow->portRect);
X    if (whichWindow == cwindow) {
X    DrawGrowIcon(whichWindow);
X    RedrawScreen();
X    }
X    EndUpdate(whichWindow);
X    SetPort(savePort);
X}
X
XDoCommand(choice)
X  long choice;
X{
X    int theMenu,theItem;
X
X    /* decode the menu choice */
X    theMenu = HiWord(choice);
X    theItem = LoWord(choice);
X
X    CursorOff();
X    HiliteMenu(theMenu);
X    switch (theMenu) {
X    case appleID:
X    DoAppleMenu(theItem);
X    break;
X    case fileID:
X    DoFileMenu(theItem);
X    break;
X    case editID:
X    DoEditMenu(theItem);
X    break;
X    case controlID:
X    DoControlMenu(theItem);
X    break;
X    }
X    HiliteMenu(0);
X    CursorOn();
X}
X
Xpascal aboutfilter(theDialog,theEvent,itemHit)
X  DialogPtr theDialog; EventRecord *theEvent; int *itemHit;
X{
X    return (theEvent->what == mouseDown ? -1 : 0);
X}
X
XDoAppleMenu(theItem)
X  int theItem;
X{
X    DialogRecord mydialog;
X    char name[256];
X    GrafPtr gp;
X    int n;
X
X    switch (theItem) {
X    case 1:
X    GetNewDialog(129,&mydialog,-1L);
X    ModalDialog(aboutfilter,&n);
X    CloseDialog(&mydialog);
X    break;
X    default:
X    GetItem(appleMenu,theItem,name);
X    GetPort(&gp);
X    OpenDeskAcc(name);
X    SetPort(gp);
X    break;
X    }
X}
X
Xpascal int filefilter(pblock)
X  ParmBlkPtr pblock;
X{
X    unsigned char *p; int len;
X    p = pblock->fileParam.ioNamePtr; len = *p++ &0xFF;
X    return (len >= 4 && strncmp(p+len-4,".lsp",4) == 0 ? 0 : -1);
X}
X
XDoFileMenu(theItem)
X  int theItem;
X{
X    SFReply loadfile;
X    Point p;
X
X    switch (theItem) {
X    case 1:    /* load */
X    case 2:    /* load noisily */
X    p.h = 100; p.v = 100;
X    SFGetFile(p,"\P",filefilter,-1,filetypes,0L,&loadfile);
X    if (loadfile.good) {
X        HiliteMenu(0);
X        SetVol(0L,loadfile.vRefNum);
X        if (xlload(PtoCstr(loadfile.fName),1,(theItem == 1 ? 0 : 1)))
X        scrflush();
X        else
X        xlabort("load error");
X    }
X    break;
X    case 4:    /* quit */
X    wrapup();
X    }
X}
X
XDoEditMenu(theItem)
X  int theItem;
X{
X    switch (theItem) {
X    case 1:    /* undo */
X    case 3:    /* cut */
X    case 4:    /* copy */
X    case 5:    /* paste */
X    case 6:    /* clear */
X    SystemEdit(theItem-1);
X    break;
X    }
X}
X
XDoControlMenu(theItem)
X  int theItem;
X{
X    scrflush();
X    HiliteMenu(0);
X    switch (theItem) {
X    case 1:    /* break */
X    xlbreak("user break",s_unbound);
X    break;
X    case 2:    /* continue */
X    xlcontinue();
X    break;
X    case 3:    /* clean-up error */
X    xlcleanup();
X    break;
X    case 4:    /* Cancel input */
X    xlabort("input canceled");
X    break;
X    case 5:    /* Top Level */
X    xltoplevel();
X    break;
X    case 7:    /* split screen */
X    scrsplit(splitmode ? FALSE : TRUE);
X    break;
X    }
X}
X
Xscrsplit(split)
X  int split;
X{
X    ShowHide(cwindow,0);
X    if (split) {
X    CheckItem(controlMenu,7,-1);
X    ShowHide(gwindow,-1);
X    MoveWindow(cwindow,sHorizontal,sVertical,-1);
X    SizeWindow(cwindow,sWidth,sHeight,-1);
X    InvalRect(&cwindow->portRect);
X    SetupScreen();
X    }
X    else {
X    CheckItem(controlMenu,7,0);
X    ShowHide(gwindow,0);
X    MoveWindow(cwindow,nHorizontal,nVertical,-1);
X    SizeWindow(cwindow,nWidth,nHeight,-1);
X    InvalRect(&cwindow->portRect);
X    SetupScreen();
X    }
X    ShowHide(cwindow,-1);
X    splitmode = split;
X}
X
XSetupScreen()
X{
X    FontInfo info;
X    Rect *pRect;
X
X    /* get font information */
X    GetFontInfo(&info);
X
X    /* compute the top and bottom margins */
X    tmargin = TextMargin + info.ascent;
X    lmargin = TextMargin;
X
X    /* compute the x and y increments */
X    xinc = info.widMax;
X    yinc = info.ascent + info.descent + info.leading;
X
X    /* compute the character dimensions of the screen */
X    pRect = &cwindow->portRect;
X    scrh = (pRect->bottom - (2 * TextMargin) - (SBarWidth - 1)) / yinc;
X    if (scrh > SCRH) scrh = SCRH;
X    scrw = (pRect->right - (2 * TextMargin) - (SBarWidth - 1)) / xinc;
X    if (scrw > SCRW) scrw = SCRW;
X
X    /* clear the screen */
X    scrclear();
X}
X
XCursorUpdate()
X{
X    if (cursorstate != -1)
X    if (cursortime < TickCount()) {
X        scrposition(x,y);
X        if (cursorstate) {
X        DrawChar(' ');
X        cursortime = TickCount() + TIMEOFF;
X        cursorstate = 0;
X        }
X        else {
X        DrawChar('_');
X        cursortime = TickCount() + TIMEON;
X        cursorstate = 1;
X        }
X    }
X}
X
XCursorOn()
X{
X    cursortime = TickCount();
X    cursorstate = 0;
X}
X
XCursorOff()
X{
X    if (cursorstate == 1) {
X    scrposition(x,y);
X    DrawChar(' ');
X    }
X    cursorstate = -1;
X}
X
XRedrawScreen()
X{
X    char *Line; int y;
X    Line = topline;
X    for (y = 0; y < scrh; y++) {
X    scrposition(0,y);
X    DrawText(Line,0,scrw);
X    nextline(&Line);
X    }
X}
X
Xnextline(pline)
X  char **pline;
X{
X    if ((*pline += SCRW) >= &screen[SCRH*SCRW])
X    *pline = screen;
X}
X
Xscrollup()
X{
X    RgnHandle updateRgn;
X    Rect rect;
X    int x;
X    updateRgn = NewRgn();
X    rect = cwindow->portRect;
X    rect.bottom -= SBarWidth - 1;
X    rect.right -= SBarWidth - 1;
X    ScrollRect(&rect,0,-yinc,updateRgn);
X    DisposeRgn(updateRgn);
X    for (x = 0; x < SCRW; x++)
X    topline[x] = ' ';
X    nextline(&topline);
X}
X
X======================== macstuff.c ==========================================
X
X/* macstuff.c - macintosh interface routines for xlisp */
X
X#include <stdio.h>
X
X/* program limits */
X#define LINEMAX     200    /* maximum line length */
X
X/* externals */
Xextern FILE *tfp;
Xextern int x;
X
X/* local variables */
Xstatic char linebuf[LINEMAX+1],*lineptr;
Xstatic int linepos[LINEMAX],linelen;
Xstatic long rseed = 1L;
X
Xosinit(name)
X  char *name;
X{
X    /* initialize the mac interface routines */
X    macinit();
X
X    /* initialize the line editor */
X    linelen = 0;
X}
X
Xosfinish()
X{
X}
X
Xoserror(msg)
X{
X    char line[100],*p;
X    sprintf(line,"error: %s\n",msg);
X    for (p = line; *p != '\0'; ++p)
X    ostputc(*p);
X}
X
Xint osrand(n)
X  int n;
X{
X    long k1;
X
X    /* make sure we don't get stuck at zero */
X    if (rseed == 0L) rseed = 1L;
X
X    /* algorithm taken from Dr. Dobbs Journal, November 1985, Page 91 */
X    k1 = rseed / 127773L;
X    if ((rseed = 16807L * (rseed - k1 * 127773L) - k1 * 2836L) < 0L)
X    rseed += 2147483647L;
X
X    /* return a random number between 0 and n-1 */
X    return ((int)(rseed % (long)n));
X}
X
XFILE *osaopen(name,mode)
X  char *name,*mode;
X{
X    return (fopen(name,mode));
X}
X
XFILE *osbopen(name,mode)
X  char *name,*mode;
X{
X    char nmode[4];
X    strcpy(nmode,mode); strcat(nmode,"b");
X    return (fopen(name,nmode));
X}
X
Xint osclose(fp)
X  FILE *fp;
X{
X    return (fclose(fp));
X}
X
Xint osagetc(fp)
X  FILE *fp;
X{
X    return (getc(fp));
X}
X
Xint osbgetc(fp)
X  FILE *fp;
X{
X    return (getc(fp));
X}
X
Xint osaputc(ch,fp)
X  int ch; FILE *fp;
X{
X    return (putc(ch,fp));
X}
X
Xint osbputc(ch,fp)
X  int ch; FILE *fp;
X{
X    return (putc(ch,fp));
X}
X
Xint ostgetc()
X{
X    int ch,i;
X
X    if (linelen--) return (*lineptr++);
X    linelen = 0;
X    while ((ch = scrgetc()) != '\r')
X    switch (ch) {
X    case EOF:
X        return (ostgetc());
X    case '\010':
X        if (linelen > 0) {
X        linelen--;
X        while (x > linepos[linelen])
X            scrdelete();
X        }
X        break;
X    default:
X        if (linelen < LINEMAX) {
X            linebuf[linelen] = ch;
X        linepos[linelen] = x;
X        linelen++;
X        }
X        scrputc(ch);
X        break;
X    }
X    linebuf[linelen++] = '\n';
X    scrputc('\r'); scrputc('\n');
X    if (tfp)
X    for (i = 0; i < linelen; ++i)
X        osaputc(linebuf[i],tfp);
X    lineptr = linebuf; linelen--;
X    return (*lineptr++);
X}
X
Xint ostputc(ch)
X  int ch;
X{
X    if (ch == '\n')
X    scrputc('\r');
X    scrputc(ch);
X    if (tfp)
X    osaputc(ch,tfp);
X    return (1);
X}
X
Xosflush()
X{
X    lineptr = linebuf;
X    linelen = 0;
X}
X
Xoscheck()
X{
X    DoEvent();
X}
X
X
X=========================== osdefs.h =====================================
X
Xextern LVAL xptsize(),
X        xhidepen(),xshowpen(),xgetpen(),xpensize(),xpenmode(),
X            xpenpat(),xpennormal(),xmoveto(),xmove(),xlineto(),xline(),
X        xshowgraphics(),xhidegraphics(),xcleargraphics(),
X        xtool(),xtool16(),xtool32(),xnewhandle(),xnewptr(),
X        xhiword(),xloword(),xrdnohang();
X
X=========================== osptrs.h =====================================
X
X{    "HIDEPEN",            S, xhidepen        }, /* 300 */
X{    "SHOWPEN",            S, xshowpen        }, /* 301 */
X{    "GETPEN",            S, xgetpen        }, /* 302 */
X{    "PENSIZE",            S, xpensize        }, /* 303 */
X{    "PENMODE",            S, xpenmode        }, /* 304 */
X{    "PENPAT",            S, xpenpat        }, /* 305 */
X{    "PENNORMAL",            S, xpennormal        }, /* 306 */
X{    "MOVETO",            S, xmoveto        }, /* 307 */
X{    "MOVE",                S, xmove        }, /* 308 */
X{    "LINETO",            S, xlineto        }, /* 309 */
X{    "LINE",                S, xline        }, /* 310 */
X{    "SHOW-GRAPHICS",        S, xshowgraphics    }, /* 311 */
X{    "HIDE-GRAPHICS",        S, xhidegraphics    }, /* 312 */
X{    "CLEAR-GRAPHICS",        S, xcleargraphics    }, /* 313 */
X{    "TOOLBOX",            S, xtool        }, /* 314 */
X{    "TOOLBOX-16",            S, xtool16        }, /* 315 */
X{    "TOOLBOX-32",            S, xtool32        }, /* 316 */
X{    "NEWHANDLE",            S, xnewhandle        }, /* 317 */
X{    "NEWPTR",            S, xnewptr        }, /* 318 */
X{    "HIWORD",            S, xhiword        }, /* 319 */
X{    "LOWORD",            S, xloword        }, /* 320 */
X{    "READ-CHAR-NO-HANG",        S, xrdnohang        }, /* 321 */
X{    "COMMAND-POINT-SIZE",        S, xptsize        }, /* 322 */
X
X
X======================== Xlisp.Rsrc ==========================================
X
XXLisp.Rsrc
X
XTYPE WIND
X  ,128
XXLISP version 2.0
X41 4 339 508
XInVisible GoAway
X0
X0
X
XTYPE WIND
X  ,129
XGraphics Window
X22 4 254 508
XInVisible NoGoAway
X2
X0
X
XTYPE DLOG
X  ,129
XAbout XLISP
X50 100 290 395
XVisible NoGoAway
X3
X0
X129
X
XTYPE DITL
X  ,129
X9
X
XstaticText
X20 20 40 275
XXLISP v2.0, February 6, 1988
X
XstaticText
X40 20 60 275
XCopyright (c) 1988, by David Betz
X
XstaticText
X60 20 80 275
XAll Rights Reserved
X
XstaticText
X90 20 110 275
XAuthor contact information:
X
XstaticText
X110 40 130 275
XDavid Betz
X
XstaticText
X130 40 150 275
X127 Taylor Road
X
XstaticText
X150 40 170 275
XPeterborough, NH  03458
X
XstaticText
X170 40 190 275
X(603) 924-6936
X
XstaticText
X200 20 220 275
XPortions Copyright Think Technologies
X
XTYPE MENU
X  ,1
X\14
XAbout XLISP
X(-
X
XTYPE MENU
X  ,256
XFile
XLoad.../L
XLoad Noisily.../N
X(-
XQuit/Q
X
XTYPE MENU
X  ,257
XEdit
XUndo/Z
X(-
XCut/X
XCopy/C
XPaste/V
XClear
X
XTYPE MENU
X  ,258
XControl
XBreak/B
XContinue/P
XClean Up Error/G
XCancel Input/U
XTop Level/T
X(-
XSplit Screen/S
X
X
X======================== Alles ist gemacht  ==================================
X
X
X--
XEric F. Johnson, Boulware Technologies, Inc.
X415 W. Travelers Trail, Burnsville, MN 55337 USA.  Phone: [phone].
[e-mail]    - or -   bungia!pai!erc
X(We have a very dumb mailer, so please send a bang-!-style return address.)
X
X
SHAR_EOF
if test 27375 -ne "`wc -c 'xlisp.mac'`"
then
    echo shar: error transmitting "'xlisp.mac'" '(should have been 27375 characters)'
fi
#    End of shell archive
exit 0
--
Gary Murphy                   uunet!mitel!sce!cognos!garym
                              ([e-mail])
[phone] x5537          Cognos Inc. P.O. Box 9707 Ottawa K1G 3N3
"There are many things which do not concern the process" - Joan of Arc